home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / ops5.arc / ops5 next >
Lisp/Scheme  |  1988-06-29  |  90KB  |  3,226 lines
  1. %========================================================================
  2. % OPS5 heavily modified by John Fitch to improve efficiency and
  3. % functionality.  This is a Cambridge LISP version.
  4.  
  5. %%% Compatability for Cambridge LISP
  6.  
  7. (setsyntax ":=+-*$&?<>" 'break!-character nil)
  8. (setsyntax ":=+-*$&?<>" 'letter t)
  9.  
  10. (setq !!excise excise)
  11. (car!-nil!-legal t)
  12.  
  13. (dm flatc (n) (list 'length (list 'explode n)))
  14.  
  15. (dm putprop (x y z) (list 'put x z y))    % Argument order
  16. (dm !!mapc (x y) (list 'mapc y x))    % Argument order
  17. (dm !!minus (x) (minus x))        % Possible syntax problem
  18. (dm prog1 l
  19.     (prog (var)
  20.       (setq var (gensym))
  21.       (return
  22.        `(prog (,var)
  23.           (setq ,var ,(car l))
  24.           ,@(append (cdr l) '((return ,xxx)))))))
  25.  
  26. (setq !*comp t)
  27.  
  28. % In general the IO model of Cambridge LISP differs from Franz
  29. % These functions patch it up a little
  30.  
  31. (de !!read (prt)
  32.    (prog (x ans)
  33.       (setq x (rds prt))
  34.       (setq ans (read))
  35.       (rds x)
  36.       (return ans)))
  37.  
  38. (de !!tyipeek (prt)
  39.    (prog (x ans)
  40.       (setq x (rds prt 'input))
  41.       (setq ans (tyipeek))
  42.       (rds x)
  43.       (return ans)))
  44.  
  45. (de !!princ (x prt)
  46.   (prog (old)
  47.       (setq old (rds prt))
  48.       (princ x)
  49.       (rds old)
  50.       (return x)))
  51.  
  52. % Useful function not defined in Cambridge LISP
  53.  
  54. (de delq (a b)
  55.      (cond
  56.            ((null b) nil)
  57.            ((eq a (car b)) (cdr b))
  58.            (t (cons (car b) (delq a (cdr b)))) ))
  59.  
  60. (fluid
  61.    '(*matrix* *buckets* *accept-file* *write-file* *trace-file*
  62.       *class-list* *brkpts* *strategy* *in-rhs* *ptrace* *wtrace*
  63.       *recording* *refracts* *real-cnt* *virtual-cnt* *max-cs*
  64.       *total-cs* *limit-token* *limit-cs* *critical* *build-trace*
  65.       *wmpart-list* *size-result-array* *result-array*
  66.       *record-array* *result-array* *size-result-array*
  67.       *pcount* *cycle-count* *action-count* *total-token* *max-token*
  68.       *current-token* *total-cs* *max-cs* *total-wm* *max-wm*
  69.       *current-wm* *conflict-set* *wmpart-list* *p-name*
  70.       *remaining-cycles* *first-node*      *feature-count* *cur-vars*
  71.       *ce-count*      *vars*      *ce-vars*      *rhs-bound-vars*
  72.       *rhs-bound-ce-vars*      *last-branch* *last-node* *subnum*
  73.       *record* *max-record-index* *record-index* *curcond* *sendtocall* *side*
  74.       *flag-part* *data-part* *alpha-flag-part* *alpha-data-part* *wm-filter*
  75.       *wm* *old-wm* *action-type* *data-matched* *last* *variable-memory*
  76.       *filters* *ppline* *halt-flag* *ce-variable-memory* *rest* *max-index*
  77.       *next-index* *break-flag* *phase* *cvec* *cved-least*
  78. ))
  79.  
  80.  
  81. % =ALG returns T if A and B are algebraicly equal.
  82. (de =alg (a b) (zerop (difference a b)))
  83.  
  84. (de ce-gelm (x k)
  85.    (prog nil
  86. loop  (cond ((eq k 1) (return (car x))))
  87.       (setq k (isub1 k))
  88.       (setq x (cdr x))
  89.       (go loop)))
  90.  
  91. % The loops in gelm were unwound so that fewer calls on DIFFERENCE
  92. % would be needed. (JPff comment: Yeak)
  93. (de gelm (x k)
  94.    (prog (ce sub)
  95.       (setq ce (iquotient k 10000))
  96.       (setq sub (idifference k (itimes ce 10000)))
  97. celoop(cond ((eq ce 0) (go ph2)))
  98.       (setq x (cdr x))
  99.       (cond ((eq ce 1) (go ph2)))
  100.       (setq x (cdr x))
  101.       (cond ((eq ce 2) (go ph2)))
  102.       (setq x (cdr x))
  103.       (cond ((eq ce 3) (go ph2)))
  104.       (setq x (cdr x))
  105.       (cond ((eq ce 4) (go ph2)))
  106.       (setq ce (idifference ce 4))
  107.       (go celoop)
  108. ph2   (setq x (car x))
  109. subloop
  110.       (cond ((eq sub 0) (go finis)))
  111.       (setq x (cdr x))
  112.       (cond ((eq sub 1) (go finis)))
  113.       (setq x (cdr x))
  114.       (cond ((eq sub 2) (go finis)))
  115.       (setq x (cdr x))
  116.       (cond ((eq sub 3) (go finis)))
  117.       (setq x (cdr x))
  118.       (cond ((eq sub 4) (go finis)))
  119.       (setq x (cdr x))
  120.       (cond ((eq sub 5) (go finis)))
  121.       (setq x (cdr x))
  122.       (cond ((eq sub 6) (go finis)))
  123.       (setq x (cdr x))
  124.       (cond ((eq sub 7) (go finis)))
  125.       (setq x (cdr x))
  126.       (cond ((eq sub 8) (go finis)))
  127.       (setq sub (idifference sub 8))
  128.       (go subloop)
  129. finis (return (car x))))
  130.  
  131.  
  132. %%% Utility functions
  133.  
  134. (de printline (x) 
  135.     (foreach y in x do 
  136.     (progn
  137.         (princ " ")
  138.         (print y))))
  139.  
  140. (de printlinec (x)
  141.     (foreach y in x do 
  142.     (progn
  143.         (princ " ")
  144.         (princ y))))
  145.  
  146. % intersect two lists using eq for the equality test
  147. (de interq (x y)
  148.    (cond
  149.       ((atom x) nil)
  150.       ((memq (car x) y) (cons (car x) (interq (cdr x) y)))
  151.       (t (interq (cdr x) y))))
  152.  
  153. (de i-g-v nil
  154.    (prog (x)
  155.       %(sstatus translink t)
  156.       %(setsyntax '{ 66)
  157.       %(setsyntax '} 66)
  158.       %(setsyntax '^ 66)
  159.       (setq *buckets* 64)
  160.       % OPS5 allows 64 named slots
  161.       (setq *accept-file* nil)
  162.       (setq *write-file* nil)
  163.       (setq *trace-file* nil)
  164.       (setq *class-list* nil)
  165.       (setq *brkpts* nil)
  166.       (setq *strategy* 'lex)
  167.       (setq *in-rhs* nil)
  168.       (setq *ptrace* t)
  169.       (setq *wtrace* nil)
  170.       (setq *recording* nil)
  171.       (setq *refracts* nil)
  172.       (setq *real-cnt* (setq *virtual-cnt* 0))
  173.       (setq *max-cs* (setq *total-cs* 0))
  174.       (setq *limit-token* 1000000)
  175.       (setq *limit-cs* 1000000)
  176.       (setq *critical* nil)
  177.       (setq *build-trace* nil)
  178.       (setq *wmpart-list* nil)
  179.       (setq *size-result-array* 127)
  180.       (setq *result-array* (mkvect *size-result-array*))
  181.       (setq *record-array* (mkvect *size-result-array*))
  182.       %%% Used to be 6 "!!!
  183.       (setq x 0)
  184. loop  (putv *result-array* x nil)
  185.       (setq x (iadd1 x))
  186.       (cond ((not (igreaterp x *size-result-array*)) (go loop)))
  187.       (make-bottom-node)
  188.       (setq *pcount* 0)
  189.       (initialize-record)
  190.       (setq *cycle-count* (setq *action-count* 0))
  191.       (setq *total-token*
  192.      (setq *max-token* (setq *current-token* 0)))
  193.       (setq *total-cs* (setq *max-cs* 0))
  194.       (setq *total-wm* (setq *max-wm* (setq *current-wm* 0)))
  195.       (setq *conflict-set* nil)
  196.       (setq *wmpart-list* nil)
  197.       (setq *p-name* nil)
  198.       (setq *remaining-cycles* 1000000)
  199.       (setq *cvec* (mkvect 64))
  200.       (setq *cvec-least* 0)))
  201.  
  202. % if the size of result-array changes, change the line in i-g-v which
  203. % sets the value of *size-result-array*
  204. (de !%warn (what where)
  205.    (prog nil
  206.       (terpri)
  207.       (princ '!?)
  208.       (and *p-name* (princ *p-name*))
  209.       (princ "..")
  210.       (princ where)
  211.       (princ "..")
  212.       (princ what)
  213.       (return where)))
  214.  
  215. (de !%error (what where)
  216.    (!%warn what where)
  217.    (throw !!error!! '!!error!!))
  218.  
  219. (de round (x) (fix (plus 0.5 x)))
  220.  
  221. (de top-levels-eq (la lb)
  222.    (prog nil
  223. lx    (cond
  224.      ((eq la lb) (return t))
  225.      ((null la) (return nil))
  226.      ((null lb) (return nil))
  227.      ((not (eq (car la) (car lb))) (return nil)))
  228.       (setq la (cdr la))
  229.       (setq lb (cdr lb))
  230.       (go lx)))
  231.  
  232.  
  233. %%% LITERAL and LITERALIZE
  234.  
  235. (df literal z
  236.    (prog (atm val old)
  237. top   (cond
  238.      ((atom z) (return 'bound))
  239.      ((not (eq (cadr z) '=)) (return (!%warn "wrong format" z))))
  240.       (setq atm (car z))
  241.       (setq val (caddr z))
  242.       (setq z (cdddr z))
  243.       (cond
  244.      ((not (numberp val))
  245.         (!%warn "can bind only to numbers" val))
  246.      ((or (not (idp atm)) (variablep atm))
  247.         (!%warn "can bind only constant atoms" atm))
  248.      ((and
  249.          (setq old (literal-binding-of atm))
  250.          (not (equal old val)))
  251.         (!%warn "attempt to rebind attribute" atm))
  252.      (t (put atm 'ops-bind val)))
  253.       (go top)))
  254.  
  255. (dm have-compiled-production nil '(not (izerop *pcount*)))
  256.  
  257. (df literalize l
  258.    (prog (class-name atts)
  259.       (setq class-name (car l))
  260.       (cond
  261.      ((have-compiled-production)
  262.         (!%warn "literalize called after p" class-name)
  263.         (return nil))
  264.      ((get class-name 'att-list)
  265.         (!%warn "attempt to redefine class" class-name)
  266.         (return nil)))
  267.       (setq *class-list* (cons class-name *class-list*))
  268.       (setq atts (remove-duplicates (cdr l)))
  269.       (test-attribute-names atts)
  270.       (mark-conflicts atts atts)
  271.       (put class-name 'att-list atts)))
  272.  
  273. (df vector-attribute l
  274.    (cond
  275.       ((have-compiled-production)
  276.      (!%warn "vector-attribute called after p" l))
  277.       (t (test-attribute-names l)
  278.      (flag l 'vector-attribute))))
  279.  
  280. (dm is-vector-attribute (att) `(flagp ,att 'vector-attribute))
  281.  
  282. (de test-attribute-names (l)
  283.    (!!mapc (function test-attribute-names2) l))
  284.  
  285. (de test-attribute-names2 (atm)
  286.    (cond
  287.       ((or (not (idp atm)) (variablep atm))
  288.      (!%warn "can bind only constant atoms" atm))))
  289.  
  290. (de finish-literalize nil
  291.    (cond
  292.       ((not (null *class-list*))
  293.      (!!mapc (function note-user-assigns) *class-list*)
  294.      (!!mapc (function assign-scalars) *class-list*)
  295.      (!!mapc (function assign-vectors) *class-list*)
  296.      (!!mapc (function put-ppdat) *class-list*)
  297.      (!!mapc (function erase-literal-info) *class-list*)
  298.      (setq *class-list* nil)
  299.      (setq *buckets* nil))))
  300.  
  301. (de put-ppdat (class)
  302.    (prog (al att ppdat)
  303.       (setq ppdat nil)
  304.       (setq al (get class 'att-list))
  305. top   (cond
  306.      ((not (atom al))
  307.         (setq att (car al))
  308.         (setq al (cdr al))
  309.         (setq ppdat
  310.            (cons (cons (literal-binding-of att) att) ppdat))
  311.         (go top)))
  312.       (putprop class ppdat 'ppdat)))
  313.  
  314.  
  315. % note-user-assigns and note-user-vector-assigns are needed only when
  316. % literal and literalize are both used in a program.  They make sure that
  317. % the assignments that are made explicitly with literal do not cause problems
  318. % for the literalized classes.
  319. (de note-user-assigns (class)
  320.    (!!mapc (function note-user-assigns2) (get class 'att-list)))
  321.  
  322. (de note-user-assigns2 (att)
  323.    (prog (num conf buck clash)
  324.       (setq num (literal-binding-of att))
  325.       (cond ((null num) (return nil)))
  326.       (setq conf (get att 'conflicts))
  327.       (setq buck (store-binding att num))
  328.       (setq clash (find-common-atom buck conf))
  329.       (and
  330.      clash
  331.      (!%warn
  332.         "attributes in a class assigned the same number"
  333.         (cons att clash)))
  334.       (return nil)))
  335.  
  336. (de note-user-vector-assigns (att given needed)
  337.    (and
  338.       (greaterp needed given)
  339.       (!%warn
  340.      "vector attribute assigned too small a value in literal"
  341.      att)))
  342.  
  343. (de assign-scalars (class)
  344.    (!!mapc (function assign-scalars2) (get class 'att-list)))
  345.  
  346. (de assign-scalars2 (att)
  347.    (prog (tlist num bucket conf)
  348.       (cond
  349.      ((literal-binding-of att) (return nil))
  350.      ((is-vector-attribute att) (return nil)))
  351.       (setq tlist (buckets))
  352.       (setq conf (get att 'conflicts))
  353. top   (cond
  354.      ((atom tlist)
  355.         (!%warn "could not generate a binding" att)
  356.         (store-binding att (!!minus 1))
  357.         (return nil)))
  358.       (setq num (caar tlist))
  359.       (setq bucket (cdar tlist))
  360.       (setq tlist (cdr tlist))
  361.       (cond
  362.      ((disjoint bucket conf) (store-binding att num))
  363.      (t (go top)))) )
  364.  
  365. (de assign-vectors (class)
  366.    (!!mapc (function assign-vectors2) (get class 'att-list)))
  367.  
  368. (de assign-vectors2 (att)
  369.    (prog (big conf new old need)
  370.       (cond ((not (is-vector-attribute att)) (return nil)))
  371.       (setq big 1)
  372.       (setq conf (get att 'conflicts))
  373. top   (cond
  374.      ((not (atom conf))
  375.         (setq new (car conf))
  376.         (setq conf (cdr conf))
  377.         (cond
  378.            ((is-vector-attribute new)
  379.           (!%warn
  380.              "class has two vector attributes"
  381.              (list att new)))
  382.            (t (setq big (max (literal-binding-of new) big))))
  383.         (go top)))
  384.       (setq need (iadd1 big))
  385.       (setq old (literal-binding-of att))
  386.       (cond
  387.      (old (note-user-vector-assigns att old need))
  388.      (t (store-binding att need)))
  389.       (return nil)))
  390.  
  391. (de disjoint (la lb) (not (find-common-atom la lb)))
  392.  
  393. (de find-common-atom (la lb)
  394.    (prog nil
  395. top   (cond
  396.      ((null la) (return nil))
  397.      ((memq (car la) lb) (return (car la)))
  398.      (t (setq la (cdr la)) (go top)))) )
  399.  
  400. (de mark-conflicts (rem all)
  401.    (cond
  402.       ((not (null rem))
  403.      (mark-conflicts2 (car rem) all)
  404.      (mark-conflicts (cdr rem) all))))
  405.  
  406. (de mark-conflicts2 (atm lst)
  407.    (prog (l)
  408.       (setq l lst)
  409. top   (cond ((atom l) (return nil)))
  410.       (conflict atm (car l))
  411.       (setq l (cdr l))
  412.       (go top)))
  413.  
  414. (de conflict (a b)
  415.    (prog (old)
  416.       (setq old (get a 'conflicts))
  417.       (and
  418.      (not (eq a b))
  419.      (not (memq b old))
  420.      (putprop a (cons b old) 'conflicts))))
  421.  
  422. (de remove-duplicates (lst)
  423.    (cond
  424.       ((atom lst) nil)
  425.       ((memq (car lst) (cdr lst)) (remove-duplicates (cdr lst)))
  426.       (t (cons (car lst) (remove-duplicates (cdr lst)))) ))
  427.  
  428. (de literal-binding-of (name) (get name 'ops-bind))
  429.  
  430. (de store-binding (name lit)
  431.    (putprop name lit 'ops-bind)
  432.    (add-bucket name lit))
  433.  
  434. (de add-bucket (name num)
  435.    (prog (buc)
  436.       (setq buc (assoc num (buckets)))
  437.       (and (not (memq name buc)) (rplacd buc (cons name (cdr buc))))
  438.       (return buc)))
  439.  
  440. (de buckets nil
  441.    (and (atom *buckets*) (setq *buckets* (make-nums *buckets*)))
  442.    *buckets*)
  443.  
  444. (de make-nums (k)
  445.    (prog (nums)
  446.       (setq nums nil)
  447. l     (cond ((ilessp k 2) (return nums)))
  448.       (setq nums (cons (ncons k) nums))
  449.       (setq k (isub1 k))
  450.       (go l)))
  451.  
  452. (de erase-literal-info (class)
  453.    (!!mapc (function erase-literal-info2) (get class 'att-list))
  454.    (remprop class 'att-list))
  455.  
  456. (de erase-literal-info2 (att) (remprop att 'conflicts))
  457.  
  458. %%% LHS Compiler
  459.  
  460. (df p z
  461.    (finish-literalize)
  462.    (princ '*)
  463.    (compile-production (car z) (cdr z))
  464.    (car z))
  465.  
  466. (de compile-production (name matrix)
  467.    (prog (erm)
  468.       (setq *p-name* name)
  469.       (setq erm (catch !!error!! (cmp-p name matrix)))
  470.       (setq *p-name* nil)))
  471.  
  472. (de peek-lex nil (car *matrix*))
  473.  
  474. (de lex nil
  475.    (prog1 (car *matrix*) (setq *matrix* (cdr *matrix*))))
  476.  
  477. (de end-of-p nil (atom *matrix*))
  478.  
  479. (de rest-of-p nil *matrix*)
  480.  
  481. (de prepare-lex (prod) (setq *matrix* prod))
  482.  
  483. (de peek-sublex nil (car *curcond*))
  484.  
  485. (de sublex nil
  486.    (prog1 (car *curcond*) (setq *curcond* (cdr *curcond*))))
  487.  
  488. (de end-of-ce nil (atom *curcond*))
  489.  
  490. (de rest-of-ce nil *curcond*)
  491.  
  492. (de prepare-sublex (ce) (setq *curcond* ce))
  493.  
  494. (de make-bottom-node nil (setq *first-node* (list '&bus nil)))
  495.  
  496. (de cmp-p (name matrix)
  497.    (prog (m bakptrs)
  498.       (cond
  499.      ((or (null name) (pairp name))
  500.         (!%error "illegal production name" name))
  501.      ((equal (get name 'production) matrix) (return nil)))
  502.       (prepare-lex matrix)
  503.       (excise-p name)
  504.       (setq bakptrs nil)
  505.       (setq *pcount* (iadd1 *pcount*))
  506.       (setq *feature-count* 0)
  507.       (setq *ce-count* 0)
  508.       (setq *vars* nil)
  509.       (setq *ce-vars* nil)
  510.       (setq *rhs-bound-vars* nil)
  511.       (setq *rhs-bound-ce-vars* nil)
  512.       (setq *last-branch* nil)
  513.       (setq m (rest-of-p))
  514. l1    (and (end-of-p) (!%error "no '-->' in production" m))
  515.       (cmp-prin)
  516.       (setq bakptrs (cons *last-branch* bakptrs))
  517.       (cond ((not (eq '--> (peek-lex))) (go l1)))
  518.       (lex)
  519.       (check-rhs (rest-of-p))
  520.       (link-new-node
  521.      (list '&p *feature-count* name (encode-dope)
  522.         (encode-ce-dope) (cons 'progn (rest-of-p))))
  523.       (putprop name (cdr (reversewoc bakptrs)) 'backpointers)
  524.       (putprop name matrix 'production)
  525.       (putprop name *last-node* 'topnode)))
  526.  
  527. (de rating-part (pnode) (cadr pnode))
  528.  
  529. (de var-part (pnode) (car (cdddr pnode)))
  530.  
  531. (de ce-var-part (pnode) (cadr (cdddr pnode)))
  532.  
  533. (de rhs-part (pnode) (caddr (cdddr pnode)))
  534.  
  535. (de excise-p (name)
  536.    (cond
  537.       ((get name 'topnode)
  538.      (printline (list name 'is 'excised))
  539.      (setq *pcount* (isub1 *pcount*))
  540.      (remove-from-conflict-set name)
  541.      (kill-node (get name 'topnode))
  542.      (remprop name 'production)
  543.      (remprop name 'backpointers)
  544.      (remprop name 'topnode))))
  545.  
  546. (de kill-node (node)
  547.    (prog nil
  548. top   (cond ((atom node) (return nil)))
  549.       (rplaca node '&old)
  550.       (setq node (cdr node))
  551.       (go top)))
  552.  
  553. (de cmp-prin nil
  554.    (prog nil
  555.       (setq *last-node* *first-node*)
  556.       (cond
  557.      ((null *last-branch*) (cmp-posce) (cmp-nobeta))
  558.      ((eq (peek-lex) '-) (cmp-negce) (cmp-not))
  559.      (t (cmp-posce) (cmp-and)))) )
  560.  
  561. (de cmp-negce nil (lex) (cmp-ce))
  562.  
  563. (de cmp-posce nil
  564.    (setq *ce-count* (iadd1 *ce-count*))
  565.    (cond ((eq (peek-lex) '!{) (cmp-ce+cevar)) (t (cmp-ce))))
  566.  
  567. (de cmp-ce+cevar nil
  568.    (prog (z)
  569.       (lex)
  570.       (cond
  571.      ((atom (peek-lex)) (cmp-cevar) (cmp-ce))
  572.      (t (cmp-ce) (cmp-cevar)))
  573.       (setq z (lex))
  574.       (or (eq z '!}) (!%error "missing '}" z))))
  575.  
  576. (de new-subnum (k)
  577.    (or (numberp k) (!%error "tab must be a number" k))
  578.    (setq *subnum* (fix k)))
  579.  
  580. (de incr-subnum nil (setq *subnum* (iadd1 *subnum*)))
  581.  
  582. (de cmp-ce nil
  583.    (prog (z)
  584.       (new-subnum 0)
  585.       (setq *cur-vars* nil)
  586.       (setq z (lex))
  587.       (and (atom z) (!%error "atomic conditions are not allowed" z))
  588.       (prepare-sublex z)
  589. la    (cond ((end-of-ce) (return nil)))
  590.       (incr-subnum)
  591.       (cmp-element)
  592.       (go la)))
  593.  
  594. (de cmp-element nil
  595.    (and (eq (peek-sublex) '!^) (cmp-tab))
  596.    (cond
  597.       ((eq (peek-sublex) '!{) (cmp-product))
  598.       (t (cmp-atomic-or-any))))
  599.  
  600. (de cmp-atomic-or-any nil
  601.    (cond ((eq (peek-sublex) '<<) (cmp-any)) (t (cmp-atomic))))
  602.  
  603. (de cmp-any nil
  604.    (prog (a z)
  605.       (sublex)
  606.       (setq z nil)
  607. la    (cond ((end-of-ce) (!%error "missing '>>" a)))
  608.       (setq a (sublex))
  609.       (cond ((not (eq '>> a)) (setq z (cons a z)) (go la)))
  610.       (link-new-node (list '&any nil (current-field) z))))
  611.  
  612. (de cmp-tab nil
  613.    (prog (r)
  614.       (sublex)
  615.       (setq r (sublex))
  616.       (setq r ($litbind r))
  617.       (new-subnum r)))
  618.  
  619. (de $litbind (x)
  620.    (prog (r)
  621.       (cond
  622.      ((and (idp x) (setq r (literal-binding-of x)))
  623.         (return r))
  624.      (t (return x)))) )
  625.  
  626. (de get-bind (x)
  627.    (prog (r)
  628.       (cond
  629.      ((and (idp x) (setq r (literal-binding-of x)))
  630.         (return r))
  631.      (t (return nil)))) )
  632.  
  633. (de cmp-atomic nil
  634.    (prog (test x)
  635.       (setq x (peek-sublex))
  636.       (cond
  637.      ((eq x '=  ) (setq test 'eq) (sublex))
  638.      ((eq x '<> ) (setq test 'ne) (sublex))
  639.      ((eq x '<  ) (setq test 'lt) (sublex))
  640.      ((eq x '<= ) (setq test 'le) (sublex))
  641.      ((eq x '>  ) (setq test 'gt) (sublex))
  642.      ((eq x '>= ) (setq test 'ge) (sublex))
  643.      ((eq x '<=>) (setq test 'xx) (sublex))
  644.      (t (setq test 'eq)))
  645.       (cmp-symbol test)))
  646.  
  647. (de cmp-product nil
  648.    (prog (save)
  649.       (setq save (rest-of-ce))
  650.       (sublex)
  651. la    (cond
  652.      ((end-of-ce)
  653.         (cond
  654.            ((member '!} save)
  655.           (!%error "wrong contex for '}" save))
  656.            (t (!%error "missing '}" save))))
  657.      ((eq (peek-sublex) '!}) (sublex) (return nil)))
  658.       (cmp-atomic-or-any)
  659.       (go la)))
  660.  
  661. (de variablep (x)
  662.     (cond ((not (idp x)) nil)
  663.       ((flagp x 'nonvariable) nil)
  664.       ((flagp x 'variable) t)
  665.       ((eq (car (explode x)) '<) 
  666.        (flag (list x) 'variable)
  667.        t)
  668.       (t (flag (list x) 'nonvariable) nil)))
  669.  
  670. (de cmp-symbol (test)
  671.    (prog (flag)
  672.       (setq flag t)
  673.       (cond ((eq (peek-sublex) '!/) (sublex) (setq flag nil)))
  674.       (cond
  675.      ((and flag (variablep (peek-sublex))) (cmp-var test))
  676.      ((numberp (peek-sublex)) (cmp-number test))
  677.      ((idp (peek-sublex)) (cmp-constant test))
  678.      (t (!%error "unrecognized symbol" (sublex)))) ))
  679.  
  680. (de cmp-constant (test)
  681.    (or
  682.       (memq test '(eq ne xx))
  683.       (!%error
  684.      "non-numeric constant after numeric predicate"
  685.      (sublex)))
  686.    (link-new-node
  687.       (list (get test 'ta) nil (current-field) (sublex))))
  688.  
  689. (de cmp-number (test)
  690.    (link-new-node
  691.       (list (get test 'tn) nil (current-field) (sublex))))
  692.  
  693. (de current-field nil (field-name *subnum*))
  694.  
  695. (de field-name (num)
  696.    (cond
  697.       ((igreaterp num 64)  (!%error "condition is too long" (rest-of-ce)))
  698.       (t num)))
  699.  
  700. %%% Compiling variables
  701. %
  702. %
  703. %
  704. % *cur-vars* are the variables in the condition element currently
  705. % being compiled.  *vars* are the variables in the earlier condition
  706. % elements.  *ce-vars* are the condition element variables.  note
  707. % that the interpreter will not confuse condition element and regular
  708. % variables even if they have the same name.
  709. %
  710. % *cur-vars* is a list of triples: (name predicate subelement-number)
  711. % eg:           ( (<x> eq 3)
  712. %                 (<y> ne 1)
  713. %                 . . . )
  714. %
  715. % *vars* is a list of triples: (name ce-number subelement-number)
  716. % eg:           ( (<x> 3 3)
  717. %                 (<y> 1 1)
  718. %                 . . . )
  719. %
  720. % *ce-vars* is a list of pairs: (name ce-number)
  721. % eg:           ( (ce1 1)
  722. %                 (<c3> 3)
  723. %                 . . . )
  724. (de var-dope (var) (atsoc var *vars*))
  725.  
  726. (de ce-var-dope (var) (atsoc var *ce-vars*))
  727.  
  728. (de cmp-var (test)
  729.    (prog (old name)
  730.       (setq name (sublex))
  731.       (setq old (atsoc name *cur-vars*))
  732.       (cond
  733.      ((and old (eq (cadr old) 'eq)) (cmp-old-eq-var test old))
  734.      ((and old (eq test 'eq)) (cmp-new-eq-var name old))
  735.      (t (cmp-new-var name test)))) )
  736.  
  737. (de cmp-new-var (name test)
  738.    (setq *cur-vars* (cons (list name test *subnum*) *cur-vars*)))
  739.  
  740. (de cmp-old-eq-var (test old)
  741.    (link-new-node
  742.       (list
  743.      (get test 'ts)
  744.      nil
  745.      (current-field)
  746.      (field-name (caddr old)))) )
  747.  
  748. (de cmp-new-eq-var (name old)
  749.    (prog (pred next)
  750.       (setq *cur-vars* (delq old *cur-vars*))
  751.       (setq next (atsoc name *cur-vars*))
  752.       (cond
  753.      (next (cmp-new-eq-var name next))
  754.      (t (cmp-new-var name 'eq)))
  755.       (setq pred (cadr old))
  756.       (link-new-node
  757.      (list
  758.         (get pred 'ts)
  759.         nil
  760.         (field-name (caddr old))
  761.         (current-field)))) )
  762.  
  763. (de cmp-cevar nil
  764.    (prog (name old)
  765.       (setq name (lex))
  766.       (setq old (atsoc name *ce-vars*))
  767.       (and
  768.      old
  769.      (!%error "condition element variable used twice" name))
  770.       (setq *ce-vars* (cons (list name 0) *ce-vars*))))
  771.  
  772. (de cmp-not nil (cmp-beta '¬))
  773.  
  774. (de cmp-nobeta nil (cmp-beta nil))
  775.  
  776. (de cmp-and nil (cmp-beta '&and))
  777.  
  778. (de cmp-beta (kind)
  779.    (prog (tlist vdope vname vpred vpos old)
  780.       (setq tlist nil)
  781. la    (cond ((atom *cur-vars*) (go lb)))
  782.       (setq vdope (car *cur-vars*))
  783.       (setq *cur-vars* (cdr *cur-vars*))
  784.       (setq vname (car vdope))
  785.       (setq vpred (cadr vdope))
  786.       (setq vpos (caddr vdope))
  787.       (setq old (atsoc vname *vars*))
  788.       (cond
  789.      (old (setq tlist (add-test tlist vdope old)))
  790.      ((neq kind '¬) (promote-var vdope)))
  791.       (go la)
  792. lb    (and kind (build-beta kind tlist))
  793.       (or (eq kind '¬) (fudge))
  794.       (setq *last-branch* *last-node*)))
  795.  
  796. (de add-test (list new old)
  797.    (prog (ttype lloc rloc)
  798.       (setq *feature-count* (iadd1 *feature-count*))
  799.       (setq ttype (get (cadr new) 'tb))
  800.       (setq rloc (encode-singleton (caddr new)))
  801.       (setq lloc (encode-pair (cadr old) (caddr old)))
  802.       (return (cons ttype (cons lloc (cons rloc list)))) ))
  803.  
  804. % the following two functions encode indices so that gelm can
  805. % decode them as fast as possible
  806. (de encode-pair (a b) (iplus (times 10000 (sub1 a)) (isub1 b)))
  807.  
  808. (de encode-singleton (a) (isub1 a))
  809.  
  810. (de promote-var (dope)
  811.    (prog (vname vpred vpos new)
  812.       (setq vname (car dope))
  813.       (setq vpred (cadr dope))
  814.       (setq vpos (caddr dope))
  815.       (or
  816.      (eq 'eq vpred)
  817.      (!%error
  818.         "illegal predicate for first occurrence"
  819.         (list vname vpred)))
  820.       (setq new (list vname 0 vpos))
  821.       (setq *vars* (cons new *vars*))))
  822.  
  823. (de fudge nil
  824.    (!!mapc (function fudge*) *vars*)
  825.    (!!mapc (function fudge*) *ce-vars*))
  826.  
  827. (de fudge* (z)
  828.    (prog (a)
  829.       (setq a (cdr z))
  830.       (rplaca a (iadd1 (car a)))) )
  831.  
  832. (de build-beta (type tests)
  833.    (prog (rpred lpred lnode lef)
  834.       (link-new-node (list '&mem nil nil (protomem)))
  835.       (setq rpred *last-node*)
  836.       (cond
  837.      ((eq type '&and)
  838.         (setq lnode (list '&mem nil nil (protomem))))
  839.      (t (setq lnode (list '&two nil nil))))
  840.       (setq lpred (link-to-branch lnode))
  841.       (cond
  842.      ((eq type '&and) (setq lef lpred))
  843.      (t (setq lef (protomem))))
  844.       (link-new-beta-node (list type nil lef rpred tests))))
  845.  
  846. (de protomem nil (list nil))
  847.  
  848. (de memory-part (mem-node) (car (cadddr mem-node)))
  849.  
  850. (de encode-dope nil
  851.    (prog (r all z k)
  852.       (setq r nil)
  853.       (setq all *vars*)
  854. la    (cond ((atom all) (return r)))
  855.       (setq z (car all))
  856.       (setq all (cdr all))
  857.       (setq k (encode-pair (cadr z) (caddr z)))
  858.       (setq r (cons (car z) (cons k r)))
  859.       (go la)))
  860.  
  861. (de encode-ce-dope nil
  862.    (prog (r all z k)
  863.       (setq r nil)
  864.       (setq all *ce-vars*)
  865. la    (cond ((atom all) (return r)))
  866.       (setq z (car all))
  867.       (setq all (cdr all))
  868.       (setq k (cadr z))
  869.       (setq r (cons (car z) (cons k r)))
  870.       (go la)))
  871.  
  872. %%% Linking the nodes
  873.  
  874. (de link-new-node (r)
  875.    (cond
  876.       ((not (member (car r) '(&p &mem &two &and ¬)))
  877.      (setq *feature-count* (iadd1 *feature-count*))))
  878.    (setq *virtual-cnt* (iadd1 *virtual-cnt*))
  879.    (setq *last-node* (link-left *last-node* r)))
  880.  
  881. (de link-to-branch (r)
  882.    (setq *virtual-cnt* (iadd1 *virtual-cnt*))
  883.    (setq *last-branch* (link-left *last-branch* r)))
  884.  
  885. (de link-new-beta-node (r)
  886.    (setq *virtual-cnt* (iadd1 *virtual-cnt*))
  887.    (setq *last-node* (link-both *last-branch* *last-node* r))
  888.    (setq *last-branch* *last-node*))
  889.  
  890. (de link-left (pred succ)
  891.    (prog (a r)
  892.       (setq a (left-outs pred))
  893.       (setq r (find-equiv-node succ a))
  894.       (cond (r (return r)))
  895.       (setq *real-cnt* (iadd1 *real-cnt*))
  896.       (attach-left pred succ)
  897.       (return succ)))
  898.  
  899. (de link-both (left right succ)
  900.    (prog (a r)
  901.       (setq a (interq (left-outs left) (right-outs right)))
  902.       (setq r (find-equiv-beta-node succ a))
  903.       (cond (r (return r)))
  904.       (setq *real-cnt* (iadd1 *real-cnt*))
  905.       (attach-left left succ)
  906.       (attach-right right succ)
  907.       (return succ)))
  908.  
  909. (de attach-right (old new)
  910.    (rplaca (cddr old) (cons new (caddr old))))
  911.  
  912. (de attach-left (old new) (rplaca (cdr old) (cons new (cadr old))))
  913.  
  914. (de right-outs (node) (caddr node))
  915.  
  916. (de left-outs (node) (cadr node))
  917.  
  918. (de find-equiv-node (node list)
  919.    (prog (a)
  920.       (setq a list)
  921. l1    (cond
  922.      ((atom a) (return nil))
  923.      ((equiv node (car a)) (return (car a))))
  924.       (setq a (cdr a))
  925.       (go l1)))
  926.  
  927. (de find-equiv-beta-node (node list)
  928.    (prog (a)
  929.       (setq a list)
  930. l1    (cond
  931.      ((atom a) (return nil))
  932.      ((beta-equiv node (car a)) (return (car a))))
  933.       (setq a (cdr a))
  934.       (go l1)))
  935.  
  936. % do not look at the predecessor fields of beta nodes; they have to be
  937. % identical because of the way the candidate nodes were found
  938. (de equiv (a b)
  939.    (and
  940.       (eq (car a) (car b))
  941.       (or
  942.      (eq (car a) '&mem)
  943.      (eq (car a) '&two)
  944.      (equal (caddr a) (caddr b)))
  945.       (equal (cdddr a) (cdddr b))))
  946.  
  947. (de beta-equiv (a b)
  948.    (and
  949.       (eq (car a) (car b))
  950.       (equal (cddddr a) (cddddr b))
  951.       (or (eq (car a) '&and) (equal (caddr a) (caddr b)))) )
  952.  
  953. % the equivalence tests are set up to consider the contents of
  954. % node memories, so they are ready for the build action
  955.  
  956.  
  957. %%% Network interpreter
  958.  
  959. (de match (flag wme)
  960.    (sendto flag (list wme) 'left (list *first-node*)))
  961.  
  962. % note that eval-nodelist is not set up to handle building
  963. % productions.  would have to add something like ops4's build-flag
  964. (de eval-nodelist (nl)
  965.    (prog nil
  966. top   (cond ((null nl) (return nil)))
  967.       (setq *sendtocall* nil)
  968.       (setq *last-node* (car nl))
  969.       (apply (caar nl) (cdar nl))
  970.       (setq nl (cdr nl))
  971.       (go top)))
  972.  
  973. (de sendto (flag data side nl)
  974.    (prog nil
  975. top   (cond ((not nl) (return nil)))
  976.       (setq *side* side)
  977.       (setq *flag-part* flag)
  978.       (setq *data-part* data)
  979.       (setq *sendtocall* t)
  980.       (setq *last-node* (car nl))
  981.       (apply (caar nl) (cdar nl))
  982.       (setq nl (cdr nl))
  983.       (go top)))
  984.  
  985. % &bus sets up the registers for the one-input nodes. 
  986. % Heavily modified by JPff
  987.  
  988. (de &bus (outs)
  989.    (prog (dp i)
  990.       (setq i 1)
  991.       (setq *alpha-flag-part* *flag-part*)
  992.       (setq dp (car (setq *alpha-data-part* *data-part*)))
  993.       (while dp 
  994.     (progn 
  995.             (putv *cvec* i (car dp))
  996.         (setq i (iadd1 i)) 
  997.         (setq dp (cdr dp))))
  998.       (setq i (isub1 i))
  999.       (cond
  1000.      ((ilessp i *cvec-least*)
  1001.       (prog (j)
  1002.         (setq j (iadd1 i))
  1003.         (while (ilessp j *cvec-least*)
  1004.         (progn (putv *cvec* j nil)
  1005.                (setq j (iadd1 j)))))))
  1006.       (setq *cvec-least* i)
  1007.       (eval-nodelist outs)))
  1008.  
  1009. (de &any (outs register const-list)
  1010.    (prog (z c)
  1011.       (setq z (getv *cvec* register))
  1012.       (cond ((numberp z) (go number)))
  1013. symbol(cond
  1014.      ((null const-list) (return nil))
  1015.      ((eq (car const-list) z) (go ok))
  1016.      (t (setq const-list (cdr const-list)) (go symbol)))
  1017. number(cond
  1018.      ((null const-list) (return nil))
  1019.      ((and (numberp (setq c (car const-list))) (=alg c z))
  1020.         (go ok))
  1021.      (t (setq const-list (cdr const-list)) (go number)))
  1022. ok    (eval-nodelist outs)))
  1023.  
  1024. (de teqa (outs register constant)
  1025.    (and (eq (getv *cvec* register) constant) (eval-nodelist outs)))
  1026.  
  1027. (put 'eq 'ta 'teqa)
  1028.  
  1029. (de tnea (outs register constant)
  1030.    (and
  1031.       (not (eq (getv *cvec* register) constant))
  1032.       (eval-nodelist outs)))
  1033.  
  1034. (put 'ne 'ta 'tnea)
  1035.  
  1036. (de txxa (outs register constant)
  1037.    (and (idp (getv *cvec* register)) (eval-nodelist outs)))
  1038.  
  1039. (put 'xx 'ta 'txxa)
  1040.  
  1041. (de teqn (outs register constant)
  1042.    (prog (z)
  1043.       (setq z (getv *cvec* register))
  1044.       (and (numberp z) (=alg z constant) (eval-nodelist outs))))
  1045.  
  1046. (put 'eq 'tn 'teqn)
  1047.  
  1048. (de tnen (outs register constant)
  1049.    (prog (z)
  1050.       (setq z (getv *cvec* register))
  1051.       (and
  1052.      (or (not (numberp z)) (not (=alg z constant)))
  1053.      (eval-nodelist outs))))
  1054.  
  1055. (put 'ne 'tn 'tnen)
  1056.  
  1057. (de txxn (outs register constant)
  1058.     (and (numberp (getv *cvec* register)) (eval-nodelist outs)))
  1059.  
  1060. (put 'xx 'tn 'txxn)
  1061.  
  1062. (de tltn (outs register constant)
  1063.    (prog (z)
  1064.       (setq z (getv *cvec* register))
  1065.       (and (numberp z) (greaterp constant z) (eval-nodelist outs))))
  1066.  
  1067. (put 'lt 'tn 'tltn)
  1068.  
  1069. (de tgtn (outs register constant)
  1070.    (prog (z)
  1071.       (setq z (getv *cvec* register))
  1072.       (and (numberp z) (greaterp z constant) (eval-nodelist outs))))
  1073.  
  1074. (put 'gt 'tn 'tgtn)
  1075.  
  1076. (de tgen (outs register constant)
  1077.    (prog (z)
  1078.       (setq z (getv *cvec* register))
  1079.       (and
  1080.      (numberp z)
  1081.      (not (greaterp constant z))
  1082.      (eval-nodelist outs))))
  1083.  
  1084. (put 'ge 'tn 'tgen)
  1085.  
  1086. (de tlen (outs register constant)
  1087.    (prog (z)
  1088.       (setq z (getv *cvec* register))
  1089.       (and
  1090.      (numberp z)
  1091.      (not (greaterp z constant))
  1092.      (eval-nodelist outs))))
  1093.  
  1094. (put 'le 'tn 'tlen)
  1095.  
  1096. (de teqs (outs vara varb)
  1097.    (prog (a b)
  1098.       (setq a (getv *cvec* vara))
  1099.       (setq b (getv *cvec* varb))
  1100.       (cond
  1101.      ((eq a b) (eval-nodelist outs))
  1102.      ((and (numberp a) (numberp b) (=alg a b))
  1103.         (eval-nodelist outs)))) )
  1104.  
  1105. (put 'eq 'ts 'teqs)
  1106.  
  1107. (de tnes (outs vara varb)
  1108.    (prog (a b)
  1109.       (setq a (getv *cvec* vara))
  1110.       (setq b (getv *cvec* varb))
  1111.       (cond
  1112.      ((eq a b) (return nil))
  1113.      ((and (numberp a) (numberp b) (=alg a b)) (return nil))
  1114.      (t (eval-nodelist outs)))) )
  1115.  
  1116. (put 'ne 'ts 'tnes)
  1117.  
  1118. (de txxs (outs vara varb)
  1119.    (prog (a b)
  1120.       (setq a (getv *cvec* vara))
  1121.       (setq b (getv *cvec* varb))
  1122.       (cond
  1123.      ((and (numberp a) (numberp b)) (eval-nodelist outs))
  1124.      ((and (not (numberp a)) (not (numberp b)))
  1125.         (eval-nodelist outs)))) )
  1126.  
  1127. (put 'xx 'ts 'txxs)
  1128.  
  1129. (de tlts (outs vara varb)
  1130.    (prog (a b)
  1131.       (setq a (getv *cvec* vara))
  1132.       (setq b (getv *cvec* varb))
  1133.       (and
  1134.      (numberp a)
  1135.      (numberp b)
  1136.      (greaterp b a)
  1137.      (eval-nodelist outs))))
  1138.  
  1139. (put 'lt 'ts 'tlts)
  1140.  
  1141. (de tgts (outs vara varb)
  1142.    (prog (a b)
  1143.       (setq a (getv *cvec* vara))
  1144.       (setq b (getv *cvec* varb))
  1145.       (and
  1146.      (numberp a)
  1147.      (numberp b)
  1148.      (greaterp a b)
  1149.      (eval-nodelist outs))))
  1150.  
  1151. (put 'gt 'ts 'tgts)
  1152.  
  1153. (de tges (outs vara varb)
  1154.    (prog (a b)
  1155.       (setq a (getv *cvec* vara))
  1156.       (setq b (getv *cvec* varb))
  1157.       (and
  1158.      (numberp a)
  1159.      (numberp b)
  1160.      (not (greaterp b a))
  1161.      (eval-nodelist outs))))
  1162.  
  1163. (put 'ge 'ts 'tges)
  1164.  
  1165. (de tles (outs vara varb)
  1166.    (prog (a b)
  1167.       (setq a (getv *cvec* vara))
  1168.       (setq b (getv *cvec* varb))
  1169.       (and
  1170.      (numberp a)
  1171.      (numberp b)
  1172.      (not (greaterp a b))
  1173.      (eval-nodelist outs))))
  1174.  
  1175. (put 'le 'ts 'tles)
  1176.  
  1177. (de &two (left-outs right-outs)
  1178.    (prog (fp dp)
  1179.       (cond
  1180.      (*sendtocall* (setq fp *flag-part*) (setq dp *data-part*))
  1181.      (t (setq fp *alpha-flag-part*) (setq dp *alpha-data-part*)))
  1182.       (sendto fp dp 'left left-outs)
  1183.       (sendto fp dp 'right right-outs)))
  1184.  
  1185. (de &mem (left-outs right-outs memory-list)
  1186.    (prog (fp dp)
  1187.       (cond
  1188.      (*sendtocall* (setq fp *flag-part*) (setq dp *data-part*))
  1189.      (t (setq fp *alpha-flag-part*) (setq dp *alpha-data-part*)))
  1190.       (sendto fp dp 'left left-outs)
  1191.       (add-token memory-list fp dp nil)
  1192.       (sendto fp dp 'right right-outs)))
  1193.  
  1194. (de &and (outs lpred rpred tests)
  1195.     (prog (mem)
  1196.     (cond
  1197.        ((eq *side* 'right)
  1198.         (cond
  1199.         ((not (setq mem (memory-part lpred))) (return nil))
  1200.         (t (and-right outs mem tests))))
  1201.        ((not (setq mem (memory-part rpred))) (return nil))
  1202.        (t (and-left outs mem tests)))))
  1203.  
  1204. (de and-left (outs mem tests)
  1205.    (prog (fp dp memdp tlist tst lind rind res)
  1206.       (setq fp *flag-part*)
  1207.       (setq dp *data-part*)
  1208. fail  (cond ((null mem) (return nil)))
  1209.       (setq memdp (car mem))
  1210.       (setq mem (cdr mem))
  1211.       (setq tlist tests)
  1212. tloop (cond ((null tlist) (go succ)))
  1213.       (setq tst (car tlist))
  1214.       (setq tlist (cdr tlist))
  1215.       (setq lind (car tlist))
  1216.       (setq tlist (cdr tlist))
  1217.       (setq rind (car tlist))
  1218.       (setq tlist (cdr tlist))
  1219.       %% the next line differs in and-left & -right
  1220.       (setq res (tst (gelm memdp rind) (gelm dp lind)))
  1221.       (cond (res (go tloop)) (t (go fail)))
  1222. succ  %% the next line differs in and-left & -right
  1223.       (sendto fp (cons (car memdp) dp) 'left outs)
  1224.       (go fail)))
  1225.  
  1226. (de and-right (outs mem tests)
  1227.    (prog (fp dp memdp tlist tst lind rind res)
  1228.       (setq fp *flag-part*)
  1229.       (setq dp *data-part*)
  1230. fail  (cond ((null mem) (return nil)))
  1231.       (setq memdp (car mem))
  1232.       (setq mem (cdr mem))
  1233.       (setq tlist tests)
  1234. tloop (cond ((null tlist) (go succ)))
  1235.       (setq tst (car tlist))
  1236.       (setq tlist (cdr tlist))
  1237.       (setq lind (car tlist))
  1238.       (setq tlist (cdr tlist))
  1239.       (setq rind (car tlist))
  1240.       (setq tlist (cdr tlist))
  1241.       %% the next line differs in and-left & -right
  1242.       (setq res (tst (gelm dp rind) (gelm memdp lind)))
  1243.       (cond (res (go tloop)) (t (go fail)))
  1244. succ  %% the next line differs in and-left & -right
  1245.       (sendto fp (cons (car dp) memdp) 'right outs)
  1246.       (go fail)))
  1247.  
  1248. (de teqb (new eqvar)
  1249.    (cond
  1250.       ((eq new eqvar) t)
  1251.       ((not (numberp new)) nil)
  1252.       ((not (numberp eqvar)) nil)
  1253.       ((=alg new eqvar) t)
  1254.       (t nil)))
  1255.  
  1256. (put 'eq 'tb 'teqb)
  1257.  
  1258. (de tneb (new eqvar)
  1259.    (cond
  1260.       ((eq new eqvar) nil)
  1261.       ((not (numberp new)) t)
  1262.       ((not (numberp eqvar)) t)
  1263.       ((=alg new eqvar) nil)
  1264.       (t t)))
  1265.  
  1266. (put 'ne 'tb 'tneb)
  1267.  
  1268. (de tltb (new eqvar)
  1269.    (cond
  1270.       ((not (numberp new)) nil)
  1271.       ((not (numberp eqvar)) nil)
  1272.       ((greaterp eqvar new) t)
  1273.       (t nil)))
  1274.  
  1275. (put 'lt 'tb 'tltb)
  1276.  
  1277. (de tgtb (new eqvar)
  1278.    (cond
  1279.       ((not (numberp new)) nil)
  1280.       ((not (numberp eqvar)) nil)
  1281.       ((greaterp new eqvar) t)
  1282.       (t nil)))
  1283.  
  1284. (put 'gt 'tb 'tgtb)
  1285.  
  1286. (de tgeb (new eqvar)
  1287.    (cond
  1288.       ((not (numberp new)) nil)
  1289.       ((not (numberp eqvar)) nil)
  1290.       ((not (greaterp eqvar new)) t)
  1291.       (t nil)))
  1292.  
  1293. (put 'ge 'tb 'tgeb)
  1294.  
  1295. (de tleb (new eqvar)
  1296.    (cond
  1297.       ((not (numberp new)) nil)
  1298.       ((not (numberp eqvar)) nil)
  1299.       ((not (greaterp new eqvar)) t)
  1300.       (t nil)))
  1301.  
  1302. (put 'le 'tb 'tleb)
  1303.  
  1304. (de txxb (new eqvar)
  1305.    (cond
  1306.       ((numberp new) (cond ((numberp eqvar) t) (t nil)))
  1307.       (t (cond ((numberp eqvar) nil) (t t)))) )
  1308.  
  1309. (put 'xx 'tb 'txxb)
  1310.  
  1311. (de &p (rating name var-dope ce-var-dope rhs)
  1312.    (prog (fp dp)
  1313.       (cond
  1314.      (*sendtocall* (setq fp *flag-part*) (setq dp *data-part*))
  1315.      (t (setq fp *alpha-flag-part*) (setq dp *alpha-data-part*)))
  1316.       (and (memq fp '(nil old)) (removecs name dp))
  1317.       (and fp (insertcs name dp rating))))
  1318.  
  1319. (de &old (a b c d e) nil)
  1320.  
  1321. (de ¬ (outs lmem rpred tests)
  1322.    (cond
  1323.       ((eq *side* 'right)
  1324.        (cond ((eq *flag-part* 'old) nil)
  1325.          (t (not-right outs (car lmem) tests))))
  1326.       (t (not-left outs (memory-part rpred) tests lmem))))
  1327.  
  1328. (de not-left (outs mem tests own-mem)
  1329.    (prog (fp dp memdp tlist tst lind rind res c)
  1330.       (setq fp *flag-part*)
  1331.       (setq dp *data-part*)
  1332.       (setq c 0)
  1333. fail  (cond ((null mem) (go fin)))
  1334.       (setq memdp (car mem))
  1335.       (setq mem (cdr mem))
  1336.       (setq tlist tests)
  1337. tloop (cond ((null tlist) (setq c (iadd1 c)) (go fail)))
  1338.       (setq tst (car tlist))
  1339.       (setq tlist (cdr tlist))
  1340.       (setq lind (car tlist))
  1341.       (setq tlist (cdr tlist))
  1342.       (setq rind (car tlist))
  1343.       (setq tlist (cdr tlist))
  1344.       %% the next line differs in not-left & -right
  1345.       (setq res (tst (gelm memdp rind) (gelm dp lind)))
  1346.       (cond (res (go tloop)) (t (go fail)))
  1347. fin   (add-token own-mem fp dp c)
  1348.       (cond ((izerop c) (sendto fp dp 'left outs)))))
  1349.  
  1350. (de not-right (outs mem tests)
  1351.    (prog (fp dp memdp tlist tst lind rind res newfp inc newc)
  1352.       (setq fp *flag-part*)
  1353.       (setq dp *data-part*)
  1354.       (cond
  1355.      ((not fp) (setq inc (!!minus 1)) (setq newfp 'new))
  1356.      ((eq fp 'new) (setq inc 1) (setq newfp nil))
  1357.      (t (return nil)))
  1358. fail  (cond ((null mem) (return nil)))
  1359.       (setq memdp (car mem))
  1360.       (setq newc (cadr mem))
  1361.       (setq tlist tests)
  1362. tloop (cond ((null tlist) (go succ)))
  1363.       (setq tst (car tlist))
  1364.       (setq tlist (cdr tlist))
  1365.       (setq lind (car tlist))
  1366.       (setq tlist (cdr tlist))
  1367.       (setq rind (car tlist))
  1368.       (setq tlist (cdr tlist))
  1369.       %% the next line differs in not-left & -right
  1370.       (setq res (tst (gelm dp rind) (gelm memdp lind)))
  1371.       (cond (res (go tloop)) (t (setq mem (cddr mem)) (go fail)))
  1372. succ  (setq newc (iplus inc newc))
  1373.       (rplaca (cdr mem) newc)
  1374.       (cond
  1375.      ((or
  1376.          (and (eq inc (!!minus 1)) (eq newc 0))
  1377.          (and (eq inc 1) (eq newc 1)))
  1378.         (sendto newfp memdp 'right outs)))
  1379.       (setq mem (cddr mem))
  1380.       (go fail)))
  1381.  
  1382. %%% Node memories
  1383.  
  1384. %(de add-token (memlis flag data-part num)
  1385. %   (prog (was-present)
  1386. %      (cond
  1387. %         ((eq flag 'new)
  1388. %         (setq was-present nil)
  1389. %            (real-add-token memlis data-part num))
  1390. %         ((not flag)
  1391. %            (setq was-present (remove-old memlis data-part num)))
  1392. %         ((eq flag 'old) (setq was-present t)))
  1393. %      (return was-present)))
  1394. (de add-token (memlis flag data-part num)
  1395.     (cond
  1396.     ((eq flag 'new) (real-add-token memlis data-part num) nil)
  1397.     ((not flag) (remove-old memlis data-part num) nil)
  1398.     ((eq flag 'old) t)
  1399.     (t nil)))
  1400.  
  1401. (de real-add-token (lis data-part num)
  1402.    (setq *current-token* (iadd1 *current-token*))
  1403.    (cond (num (rplaca lis (cons num (car lis)))) )
  1404.    (rplaca lis (cons data-part (car lis))))
  1405.  
  1406. (de remove-old (lis data num)
  1407.    (cond
  1408.       (num (remove-old-num lis data))
  1409.       (t (remove-old-no-num lis data))))
  1410.  
  1411. (de remove-old-num (lis data)
  1412.    (prog (m next last)
  1413.       (setq m (car lis))
  1414.       (cond
  1415.      ((atom m) (return nil))
  1416.      ((top-levels-eq data (car m))
  1417.         (setq *current-token* (isub1 *current-token*))
  1418.         (rplaca lis (cddr m))
  1419.         (return (car m))))
  1420.       (setq next m)
  1421. loop  (setq last next)
  1422.       (setq next (cddr next))
  1423.       (cond
  1424.      ((atom next) (return nil))
  1425.      ((top-levels-eq data (car next))
  1426.         (rplacd (cdr last) (cddr next))
  1427.         (setq *current-token* (isub1 *current-token*))
  1428.         (return (car next)))
  1429.      (t (go loop)))) )
  1430.  
  1431. (de remove-old-no-num (lis data)
  1432.    (prog (m next last)
  1433.       (setq m (car lis))
  1434.       (cond
  1435.      ((atom m) (return nil))
  1436.      ((top-levels-eq data (car m))
  1437.         (setq *current-token* (isub1 *current-token*))
  1438.         (rplaca lis (cdr m))
  1439.         (return (car m))))
  1440.       (setq next m)
  1441. loop  (setq last next)
  1442.       (setq next (cdr next))
  1443.       (cond
  1444.      ((atom next) (return nil))
  1445.      ((top-levels-eq data (car next))
  1446.         (rplacd last (cdr next))
  1447.         (setq *current-token* (isub1 *current-token*))
  1448.         (return (car next)))
  1449.      (t (go loop)))) )
  1450.  
  1451. %%% Conflict Resolution
  1452. %
  1453. %
  1454. % each conflict set element is a list of the following form:
  1455. % ((p-name . data-part) (sorted wm-recency) special-case-number)
  1456.  
  1457. (de removecs (name data)
  1458.    (prog (cr-data inst cs)
  1459.       (setq cr-data (cons name data))
  1460.       (setq cs *conflict-set*)
  1461. l:    (cond ((null cs) (record-refract name data) (return nil)))
  1462.       (setq inst (car cs))
  1463.       (setq cs (cdr cs))
  1464.       (cond ((not (top-levels-eq (car inst) cr-data)) (go l:)))
  1465.       (setq *conflict-set* (delq inst *conflict-set*))))
  1466.  
  1467. (de insertcs (name data rating)
  1468.    (prog (instan)
  1469.       (cond ((refracted name data) (return nil)))
  1470.       (setq instan (list (cons name data) (order-tags data) rating))
  1471.       (and (atom *conflict-set*) (setq *conflict-set* nil))
  1472.       (return (setq *conflict-set* (cons instan *conflict-set*)))) )
  1473.  
  1474. (de order-tags (dat)
  1475.    (prog (tags)
  1476.       (setq tags nil)
  1477. l1:   (cond ((atom dat) (go l2:)))
  1478.       (setq tags (cons (creation-time (car dat)) tags))
  1479.       (setq dat (cdr dat))
  1480.       (go l1:)
  1481. l2:   (cond
  1482.      ((eq *strategy* 'mea)
  1483.         (return (cons (car tags) (dsort (cdr tags)))) )
  1484.      (t (return (dsort tags)))) ))
  1485.  
  1486. % destructively sort x into descending order
  1487. (de dsort (x)
  1488.    (prog (sorted cur next cval nval)
  1489.       (cond ((atom (cdr x)) (return x)))
  1490. loop  (setq sorted t)
  1491.       (setq cur x)
  1492.       (setq next (cdr x))
  1493. chek  (setq cval (car cur))
  1494.       (setq nval (car next))
  1495.       (cond
  1496.      ((greaterp nval cval)
  1497.         (setq sorted nil)
  1498.         (rplaca cur nval)
  1499.         (rplaca next cval)))
  1500.       (setq cur next)
  1501.       (setq next (cdr cur))
  1502.       (cond
  1503.      ((not (null next)) (go chek))
  1504.      (sorted (return x))
  1505.      (t (go loop)))) )
  1506.  
  1507. (de conflict-resolution nil
  1508.    (prog (best len)
  1509.       (setq len (length *conflict-set*))
  1510.       (cond ((igreaterp len *max-cs*) (setq *max-cs* len)))
  1511.       (setq *total-cs* (iplus *total-cs* len))
  1512.       (cond
  1513.      (*conflict-set*
  1514.         (setq best (best-of *conflict-set*))
  1515.         (setq *conflict-set* (delq best *conflict-set*))
  1516.         (return (pname-instantiation best)))
  1517.      (t (return nil)))) )
  1518.  
  1519. (de best-of (set) (best-of* (car set) (cdr set)))
  1520.  
  1521. (de best-of* (best rem)
  1522.    (cond
  1523.       ((not rem) best)
  1524.       ((conflict-set-compare best (car rem))
  1525.      (best-of* best (cdr rem)))
  1526.       (t (best-of* (car rem) (cdr rem)))) )
  1527.  
  1528. (de remove-from-conflict-set (name)
  1529.    (prog (cs entry)
  1530. l1    (setq cs *conflict-set*)
  1531. l2    (cond ((atom cs) (return nil)))
  1532.       (setq entry (car cs))
  1533.       (setq cs (cdr cs))
  1534.       (cond
  1535.      ((eq name (caar entry))
  1536.         (setq *conflict-set* (delq entry *conflict-set*))
  1537.         (go l1))
  1538.      (t (go l2)))) )
  1539.  
  1540. (de pname-instantiation (conflict-elem) (car conflict-elem))
  1541.  
  1542. (de order-part (conflict-elem) (cdr conflict-elem))
  1543.  
  1544. (de instantiation (conflict-elem)
  1545.    (cdr (pname-instantiation conflict-elem)))
  1546.  
  1547. (de conflict-set-compare (x y)
  1548.    (prog (x-order y-order xl yl xv yv)
  1549.       (setq x-order (order-part x))
  1550.       (setq y-order (order-part y))
  1551.       (setq xl (car x-order))
  1552.       (setq yl (car y-order))
  1553. data  (cond
  1554.      ((and (null xl) (null yl)) (go ps))
  1555.      ((null yl) (return t))
  1556.      ((null xl) (return nil)))
  1557.       (setq xv (car xl))
  1558.       (setq yv (car yl))
  1559.       (cond
  1560.      ((greaterp xv yv) (return t))
  1561.      ((greaterp yv xv) (return nil)))
  1562.       (setq xl (cdr xl))
  1563.       (setq yl (cdr yl))
  1564.       (go data)
  1565. ps    (setq xl (cdr x-order))
  1566.       (setq yl (cdr y-order))
  1567. psl   (cond ((null xl) (return t)))
  1568.       (setq xv (car xl))
  1569.       (setq yv (car yl))
  1570.       (cond
  1571.      ((greaterp xv yv) (return t))
  1572.      ((greaterp yv xv) (return nil)))
  1573.       (setq xl (cdr xl))
  1574.       (setq yl (cdr yl))
  1575.       (go psl)))
  1576.  
  1577. (de conflict-set nil
  1578.    (prog (cnts cs p z best)
  1579.       (setq cnts nil)
  1580.       (setq cs *conflict-set*)
  1581. l1:   (cond ((atom cs) (go l2:)))
  1582.       (setq p (caaar cs))
  1583.       (setq cs (cdr cs))
  1584.       (setq z (atsoc p cnts))
  1585.       (cond
  1586.      ((null z) (setq cnts (cons (cons p 1) cnts)))
  1587.      (t (rplacd z (iadd1 (cdr z)))) )
  1588.       (go l1:)
  1589. l2:   (cond
  1590.      ((atom cnts)
  1591.         (setq best (best-of *conflict-set*))
  1592.         (terpri)
  1593.         (return (list (caar best) 'dominates))))
  1594.       (terpri)
  1595.       (princ (caar cnts))
  1596.       (cond
  1597.      ((greaterp (cdar cnts) 1)
  1598.         (princ "        (")
  1599.         (princ (cdar cnts))
  1600.         (princ " occurrences)")))
  1601.       (setq cnts (cdr cnts))
  1602.       (go l2:)))
  1603.  
  1604. %%% WM maintaining functions
  1605. %
  1606. % The order of operations in the following two functions is critical.
  1607. % add-to-wm order: (1) change wm (2) record change (3) match
  1608. % remove-from-wm order: (1) record change (2) match (3) change wm
  1609. % (back will not restore state properly unless wm changes are recorded
  1610. % before the cs changes that they cause)  (match will give errors if
  1611. % the thing matched is not in wm at the time)
  1612.  
  1613. (de add-to-wm (wme override)
  1614.    (prog (fa z part timetag port)
  1615.       (setq *critical* t)
  1616.       (setq *current-wm* (iadd1 *current-wm*))
  1617.       (and
  1618.      (greaterp *current-wm* *max-wm*)
  1619.      (setq *max-wm* *current-wm*))
  1620.       (setq *action-count* (iadd1 *action-count*))
  1621.       (setq fa (wm-hash wme))
  1622.       (or
  1623.      (memq fa *wmpart-list*)
  1624.      (setq *wmpart-list* (cons fa *wmpart-list*)))
  1625.       (setq part (get fa 'wmpart*))
  1626.       (cond
  1627.      (override (setq timetag override))
  1628.      (t (setq timetag *action-count*)))
  1629.       (setq z (cons wme timetag))
  1630.       (putprop fa (cons z part) 'wmpart*)
  1631.       (record-change '=>wm *action-count* wme)
  1632.       (match 'new wme)
  1633.       (setq *critical* nil)
  1634.       (cond
  1635.      ((and *in-rhs* *wtrace*)
  1636.         (setq port (trace-file))
  1637.         (terpri port)
  1638.         (!!princ "=>wm: " port)
  1639.         (ppelm wme port)))) )
  1640.  
  1641. % remove-from-wm uses eq, not equal to determine if wme is present
  1642. (de remove-from-wm (wme)
  1643.    (prog (fa z part timetag port)
  1644.       (setq fa (wm-hash wme))
  1645.       (setq part (get fa 'wmpart*))
  1646.       (setq z (atsoc wme part))
  1647.       (cond ((null z) (return nil)))
  1648.       (setq timetag (cdr z))
  1649.       (cond
  1650.      ((and *wtrace* *in-rhs*)
  1651.         (setq port (trace-file))
  1652.         (terpri port)
  1653.         (!!princ "<=wm: " port)
  1654.         (ppelm wme port)))
  1655.       (setq *action-count* (iadd1 *action-count*))
  1656.       (setq *critical* t)
  1657.       (setq *current-wm* (sub1 *current-wm*))
  1658.       (record-change '<=wm timetag wme)
  1659.       (match nil wme)
  1660.       (putprop fa (delq z part) 'wmpart*)
  1661.       (setq *critical* nil)))
  1662.  
  1663. % mapwm maps down the elements of wm, applying fn to each element
  1664. % each element is of form (datum . creation-time)
  1665. (de mapwm (fn)
  1666.    (prog (wmpl part)
  1667.       (setq wmpl *wmpart-list*)
  1668. lab1  (cond ((atom wmpl) (return nil)))
  1669.       (setq part (get (car wmpl) 'wmpart*))
  1670.       (setq wmpl (cdr wmpl))
  1671.       (!!mapc fn part)
  1672.       (go lab1)))
  1673.  
  1674. (df wm a
  1675.    (!!mapc (function (lambda (z) (terpri) (ppelm z nil))) (get-wm a))
  1676.    nil)
  1677.  
  1678. (de get-wm (z)
  1679.    (setq *wm-filter* z)
  1680.    (setq *wm* nil)
  1681.    (mapwm (function get-wm2))
  1682.    (prog1 *wm* (setq *wm* nil)))
  1683.  
  1684. (de get-wm2 (elem)
  1685.    (cond
  1686.       ((or (null *wm-filter*) (member (cdr elem) *wm-filter*))
  1687.      (setq *wm* (cons (car elem) *wm*)))) )
  1688.  
  1689. (de wm-hash (x)
  1690.    (cond
  1691.       ((not x) '<default>)
  1692.       ((not (car x)) (wm-hash (cdr x)))
  1693.       ((idp (car x)) (car x))
  1694.       (t (wm-hash (cdr x)))) )
  1695.  
  1696. (de creation-time (wme)
  1697.    (cdr (atsoc wme (get (wm-hash wme) 'wmpart*))))
  1698.  
  1699. (de refresh nil
  1700.    (prog nil
  1701.       (setq *old-wm* nil)
  1702.       (mapwm (function refresh-collect))
  1703.       (!!mapc (function refresh-del) *old-wm*)
  1704.       (!!mapc (function refresh-add) *old-wm*)
  1705.       (setq *old-wm* nil)))
  1706.  
  1707. (de refresh-collect (x) (setq *old-wm* (cons x *old-wm*)))
  1708.  
  1709. (de refresh-del (x) (remove-from-wm (car x)))
  1710.  
  1711. (de refresh-add (x) (add-to-wm (car x) (cdr x)))
  1712.  
  1713. (de trace-file ()
  1714.    (prog (port)
  1715.       (setq port nil)
  1716.       (cond
  1717.      (*trace-file*
  1718.         (setq port ($ofile *trace-file*))
  1719.         (cond
  1720.            ((null port)
  1721.           (!%warn "trace: file has been closed" *trace-file*)
  1722.           (setq port nil)))) )
  1723.       (return port)))
  1724.  
  1725. %%% Basic functions for RHS evaluation
  1726.  
  1727. (de eval-rhs (pname data)
  1728.    (prog (node port)
  1729.       (cond
  1730.      (*ptrace*
  1731.         (setq port (trace-file))
  1732.         (terpri port)
  1733.         (!!princ *cycle-count* port)
  1734.         (!!princ ". " port)
  1735.         (!!princ pname port)
  1736.         (time-tag-print data port)))
  1737.       (setq *data-matched* data)
  1738.       (setq *p-name* pname)
  1739.       (setq *last* nil)
  1740.       (setq node (get pname 'topnode))
  1741.       (init-var-mem (var-part node))
  1742.       (init-ce-var-mem (ce-var-part node))
  1743.       (begin-record pname data)
  1744.       (setq *in-rhs* t)
  1745.       (eval (rhs-part node))
  1746.       (setq *in-rhs* nil)
  1747.       (end-record)))
  1748.  
  1749. (de time-tag-print (data port)
  1750.    (cond
  1751.       ((not (null data))
  1752.      (time-tag-print (cdr data) port)
  1753.      (!!princ " " port)
  1754.      (!!princ (creation-time (car data)) port))))
  1755.  
  1756. (de init-var-mem (vlist)
  1757.    (prog (v ind r)
  1758.       (setq *variable-memory* nil)
  1759. top   (cond ((atom vlist) (return nil)))
  1760.       (setq v (car vlist))
  1761.       (setq ind (cadr vlist))
  1762.       (setq vlist (cddr vlist))
  1763.       (setq r (gelm *data-matched* ind))
  1764.       (setq *variable-memory* (cons (cons v r) *variable-memory*))
  1765.       (go top)))
  1766.  
  1767. (de init-ce-var-mem (vlist)
  1768.    (prog (v ind r)
  1769.       (setq *ce-variable-memory* nil)
  1770. top   (cond ((atom vlist) (return nil)))
  1771.       (setq v (car vlist))
  1772.       (setq ind (cadr vlist))
  1773.       (setq vlist (cddr vlist))
  1774.       (setq r (ce-gelm *data-matched* ind))
  1775.       (setq *ce-variable-memory*
  1776.      (cons (cons v r) *ce-variable-memory*))
  1777.       (go top)))
  1778.  
  1779. (de make-ce-var-bind (var elem)
  1780.    (setq *ce-variable-memory*
  1781.       (cons (cons var elem) *ce-variable-memory*)))
  1782.  
  1783. (de make-var-bind (var elem)
  1784.    (setq *variable-memory* (cons (cons var elem) *variable-memory*)))
  1785.  
  1786. (de $varbind (x)
  1787.    (prog (r)
  1788.       (cond ((not *in-rhs*) (return x)))
  1789.       (setq r (atsoc x *variable-memory*))
  1790.       (cond (r (return (cdr r))) (t (return x)))) )
  1791.  
  1792. (de get-ce-var-bind (x)
  1793.    (prog (r)
  1794.       (cond ((numberp x) (return (get-num-ce x))))
  1795.       (setq r (atsoc x *ce-variable-memory*))
  1796.       (cond (r (return (cdr r))) (t (return nil)))) )
  1797.  
  1798. (de get-num-ce (x)
  1799.    (prog (r l d)
  1800.       (setq r *data-matched*)
  1801.       (setq l (length r))
  1802.       (setq d (difference l x))
  1803.       (cond ((greaterp 0 d) (return nil)))
  1804. la    (cond
  1805.      ((null r) (return nil))
  1806.      ((greaterp 1 d) (return (car r))))
  1807.       (setq d (sub1 d))
  1808.       (setq r (cdr r))
  1809.       (go la)))
  1810.  
  1811. (de build-collect (z)
  1812.    (prog (r)
  1813. la    (cond ((atom z) (return nil)))
  1814.       (setq r (car z))
  1815.       (setq z (cdr z))
  1816.       (cond
  1817.      ((pairp r) ($value '!() (build-collect r) ($value '!) ))
  1818.      ((eq r '!!) ($change (car z)) (setq z (cdr z)))
  1819.      (t ($value r)))
  1820.       (go la)))
  1821.  
  1822. (de unflat (x) (setq *rest* x) (unflat*))
  1823.  
  1824. (de unflat* nil
  1825.    (prog (c)
  1826.       (cond ((atom *rest*) (return nil)))
  1827.       (setq c (car *rest*))
  1828.       (setq *rest* (cdr *rest*))
  1829.       (cond
  1830.      ((eq c '!() (return (cons (unflat*) (unflat*))))
  1831.      ((eq c '!)) (return nil))
  1832.      (t (return (cons c (unflat*)))) )))
  1833.  
  1834. (de $change (x)
  1835.    (prog nil
  1836.       (cond
  1837.      ((pairp x) (eval-function x))
  1838.      (t ($value ($varbind x)))) ))
  1839.  
  1840. (de eval-args (z)
  1841.    (prog (r)
  1842.       (rhs-tab 1)
  1843. la    (cond ((atom z) (return nil)))
  1844.       (setq r (car z))
  1845.       (setq z (cdr z))
  1846.       (cond
  1847.      ((eq r '!^)
  1848.         (rhs-tab (car z))
  1849.         (setq r (cadr z))
  1850.         (setq z (cddr z))))
  1851.       (cond
  1852.      ((eq r '!/) ($value (car z)) (setq z (cdr z)))
  1853.      (t ($change r)))
  1854.       (go la)))
  1855.  
  1856. (de eval-function (form)
  1857.    (cond
  1858.       ((not *in-rhs*)
  1859.      (!%warn "functions cannot be used at top level" (car form)))
  1860.       (t (eval form))))
  1861.  
  1862.  
  1863. %%% Functions to manipulate the result array
  1864.  
  1865. (de $reset nil (setq *max-index* 0) (setq *next-index* 1))
  1866.  
  1867. % rhs-tab implements the tab ('^') function in the rhs.  it has
  1868. % four responsibilities:
  1869. %       - to move the array pointers
  1870. %       - to watch for tabbing off the left end of the array
  1871. %         (ie, to watch for pointers less than 1)
  1872. %       - to watch for tabbing off the right end of the array
  1873. %       - to write nil in all the slots that are skipped
  1874. % the last is necessary if the result array is not to be cleared
  1875. % after each use% if rhs-tab did not do this, $reset
  1876. % would be much slower.
  1877.  
  1878. (de rhs-tab (z) ($tab ($varbind z)))
  1879.  
  1880. (de $tab (z)
  1881.    (prog (edge next)
  1882.       (setq next ($litbind z))
  1883.       (and (floatp next) (setq next (fix next)))
  1884.       (cond
  1885.      ((or
  1886.          (not (numberp next))
  1887.          (greaterp next *size-result-array*)
  1888.          (greaterp 1 next))
  1889.         (!%warn "illegal index after ^" next)
  1890.         (return *next-index*)))
  1891.       (setq edge (isub1 next))
  1892.       (cond ((greaterp *max-index* edge) (go ok)))
  1893. clear (cond ((eq *max-index* edge) (go ok)))
  1894.       (putv *result-array* edge nil)
  1895.       (setq edge (isub1 edge))
  1896.       (go clear)
  1897. ok    (setq *next-index* next)
  1898.       (return next)))
  1899.  
  1900. (de $value (v)
  1901.    (cond
  1902.       ((greaterp *next-index* *size-result-array*)
  1903.      (!%warn "index too large" *next-index*))
  1904.       (t (and
  1905.         (greaterp *next-index* *max-index*)
  1906.         (setq *max-index* *next-index*))
  1907.      (putv *result-array* *next-index* v)
  1908.      (setq *next-index* (iadd1 *next-index*)))) )
  1909.  
  1910. (de use-result-array nil
  1911.    (prog (k r)
  1912.       (setq k *max-index*)
  1913.       (setq r nil)
  1914. top   (cond ((eq k 0) (return r)))
  1915.       (setq r (cons (getv *result-array* k) r))
  1916.       (setq k (isub1 k))
  1917.       (go top)))
  1918.  
  1919. (de $assert nil
  1920.    (setq *last* (use-result-array))
  1921.    (add-to-wm *last* nil))
  1922.  
  1923. (de $parametercount nil *max-index*)
  1924.  
  1925. (de $parameter (k)
  1926.    (cond
  1927.       ((or
  1928.       (not (numberp k))
  1929.       (igreaterp k *size-result-array*)
  1930.       (ilessp k 1))
  1931.      (!%warn "illegal parameter number " k)
  1932.      nil)
  1933.       ((igreaterp k *max-index*) nil)
  1934.       (t (getv *result-array* k))))
  1935.  
  1936. %%% RHS actions
  1937.  
  1938. (df make z
  1939.    (prog nil
  1940.       ($reset)
  1941.       (eval-args z)
  1942.       ($assert)))
  1943.  
  1944. (df modify z
  1945.    (prog (old)
  1946.       (cond
  1947.      ((not *in-rhs*)
  1948.         (!%warn "cannot be called at top level" 'modify)
  1949.         (return nil)))
  1950.       (setq old (get-ce-var-bind (car z)))
  1951.       (cond
  1952.      ((null old)
  1953.         (!%warn
  1954.            "modify: first argument must be an element variable"
  1955.            (car z))
  1956.         (return nil)))
  1957.       (remove-from-wm old)
  1958.       (setq z (cdr z))
  1959.       ($reset)
  1960. copy  (cond ((atom old) (go fin)))
  1961.       ($change (car old))
  1962.       (setq old (cdr old))
  1963.       (go copy)
  1964. fin   (eval-args z)
  1965.       ($assert)))
  1966.  
  1967. (df bind z
  1968.    (prog (val)
  1969.       (cond
  1970.      ((not *in-rhs*)
  1971.         (!%warn "cannot be called at top level" 'bind)
  1972.         (return nil)))
  1973.       (cond
  1974.      ((ilessp (length z) 1)
  1975.         (!%warn "bind: wrong number of arguments to" z)
  1976.         (return nil))
  1977.      ((not (idp (car z)))
  1978.         (!%warn "bind: illegal argument" (car z))
  1979.         (return nil))
  1980.      ((eq (length z) 1) (setq val (gensym)))
  1981.      (t ($reset) (eval-args (cdr z)) (setq val ($parameter 1))))
  1982.       (make-var-bind (car z) val)))
  1983.  
  1984. (df cbind z
  1985.    (cond
  1986.       ((not *in-rhs*)
  1987.      (!%warn "cannot be called at top level" 'cbind))
  1988.       ((not (eq (length z) 1))
  1989.      (!%warn "cbind: wrong number of arguments" z))
  1990.       ((not (idp (car z)))
  1991.      (!%warn "cbind: illegal argument" (car z)))
  1992.       ((null *last*) (!%warn "cbind: nothing added yet" (car z)))
  1993.       (t (make-ce-var-bind (car z) *last*))))
  1994.  
  1995. (df remove z
  1996.    (prog (old)
  1997.       (cond ((not *in-rhs*) (return (top-level-remove z))))
  1998. top   (cond ((atom z) (return nil)))
  1999.       (setq old (get-ce-var-bind (car z)))
  2000.       (cond
  2001.      ((null old)
  2002.         (!%warn
  2003.            "remove: argument not an element variable"
  2004.            (car z))
  2005.         (return nil)))
  2006.       (remove-from-wm old)
  2007.       (setq z (cdr z))
  2008.       (go top)))
  2009.  
  2010. (df call z
  2011.    (prog (f)
  2012.       (setq f (car z))
  2013.       ($reset)
  2014.       (eval-args (cdr z))
  2015.       (f)))
  2016.  
  2017. (df write z
  2018.    (prog (port max k x needspace)
  2019.       (cond
  2020.      ((not *in-rhs*)
  2021.         (!%warn "cannot be called at top level" 'write)
  2022.         (return nil)))
  2023.       ($reset)
  2024.       (eval-args z)
  2025.       (setq k 1)
  2026.       (setq max ($parametercount))
  2027.       (cond
  2028.      ((ilessp max 1)
  2029.         (!%warn "write: nothing to print" z)
  2030.         (return nil)))
  2031.       (setq port (default-write-file))
  2032.       (setq x ($parameter 1))
  2033.       (cond
  2034.      ((and (idp x) ($ofile x))
  2035.         (setq port ($ofile x))
  2036.         (setq k 2)))
  2037.       (setq needspace t)
  2038. la    (cond ((greaterp k max) (return nil)))
  2039.       (setq x ($parameter k))
  2040.       (cond
  2041.      ((eq x "=== C R L F ===")
  2042.         (setq needspace nil)
  2043.         (terpri port))
  2044.      ((eq x "=== R J U S T ===")
  2045.         (setq k (iplus 2 k))
  2046.         (do-rjust ($parameter (isub1 k)) ($parameter k) port))
  2047.      ((eq x "=== T A B T O ===")
  2048.         (setq needspace nil)
  2049.         (setq k (iadd1 k))
  2050.         (do-tabto ($parameter k) port))
  2051.      (t (and needspace (!!princ " " port))
  2052.         (setq needspace t)
  2053.         (!!princ x port)))
  2054.       (setq k (iadd1 k))
  2055.       (go la)))
  2056.  
  2057. (de default-write-file ()
  2058.    (prog (port)
  2059.       (setq port nil)
  2060.       (cond
  2061.      (*write-file*
  2062.         (setq port ($ofile *write-file*))
  2063.         (cond
  2064.            ((null port)
  2065.           (!%warn "write: file has been closed" *write-file*)
  2066.           (setq port nil)))) )
  2067.       (return port)))
  2068.  
  2069. (de do-rjust (width value port k)
  2070.    (prog (size)
  2071.       (cond
  2072.      ((eq value "=== T A B T O ===")
  2073.         (!%warn "rjust cannot precede this function" 'tabto)
  2074.         (return nil))
  2075.      ((eq value "=== C R L F ===")
  2076.         (!%warn "rjust cannot precede this function" 'crlf)
  2077.         (return nil))
  2078.      ((eq value "=== R J U S T ===")
  2079.         (!%warn "rjust cannot precede this function" 'rjust)
  2080.         (return nil)))
  2081.       (setq size (flatc value (iadd1 width)))
  2082.       (cond
  2083.      ((greaterp size width)
  2084.         (!!princ " " port)
  2085.         (!!princ value port)
  2086.         (return nil)))
  2087.       (setq k (difference width size))
  2088.       (while (greaterp k 0)
  2089.      (progn (setq k (isub1 k))
  2090.         (!!princ " " port)))
  2091.       (!!princ value port)))
  2092.  
  2093. (de do-tabto (col port)
  2094.    (prog (pos k)
  2095.       (setq pos (iadd1 (posn port)))
  2096.       (cond ((greaterp pos col) (terpri port) (setq pos 1)))
  2097.       (setq k (difference col pos))
  2098.       (while (greaterp k 0)
  2099.      (progn (setq k (isub1 k))
  2100.         (!!princ " " port)))
  2101.       (return nil)))
  2102.  
  2103. (de halt nil
  2104.    (cond
  2105.       ((not *in-rhs*) (!%warn "cannot be called at top level" 'halt))
  2106.       (t (setq *halt-flag* t))))
  2107.  
  2108. (de build z
  2109.    (prog (r)
  2110.       (cond
  2111.      ((not *in-rhs*)
  2112.         (!%warn "cannot be called at top level" 'build)
  2113.         (return nil)))
  2114.       ($reset)
  2115.       (build-collect z)
  2116.       (setq r (unflat (use-result-array)))
  2117.       (and *build-trace* (*build-trace* r))
  2118.       (compile-production (car r) (cdr r))))
  2119.  
  2120. (df openfile z
  2121.    (prog (file mode id)
  2122.       ($reset)
  2123.       (eval-args z)
  2124.       (cond
  2125.      ((not (eq ($parametercount) 3))
  2126.         (!%warn "openfile: wrong number of arguments" z)
  2127.         (return nil)))
  2128.       (setq id ($parameter 1))
  2129.       (setq file ($parameter 2))
  2130.       (setq mode ($parameter 3))
  2131.       (cond
  2132.      ((not (idp id))
  2133.         (!%warn "openfile: file id must be a symbolic atom" id)
  2134.         (return nil))
  2135.      ((null id)
  2136.         (!%warn
  2137.            "openfile: 'nil' is reserved for the terminal"
  2138.            nil)
  2139.         (return nil))
  2140.      ((or ($ifile id) ($ofile id))
  2141.         (!%warn "openfile: name already in use" id)
  2142.         (return nil)))
  2143.       (cond
  2144.      ((eq mode 'in) (putprop id (open file 'input) 'inputfile))
  2145.      ((eq mode 'out) (putprop id (open file 'output) 'outputfile))
  2146.      (t (!%warn "openfile: illegal mode" mode) (return nil)))
  2147.       (return nil)))
  2148.  
  2149. (de $ifile (x) (get x 'inputfile))
  2150.  
  2151. (de $ofile (x) (get x 'outputfile))
  2152.  
  2153. (df closefile z
  2154.    ($reset)
  2155.    (eval-args z)
  2156.    (!!mapc (function closefile2) (use-result-array)))
  2157.  
  2158. (de closefile2 (file)
  2159.    (prog (port)
  2160.       (cond
  2161.      ((not (idp file))
  2162.         (!%warn "closefile: illegal file identifier" file))
  2163.      ((setq port ($ifile file))
  2164.         (close port)
  2165.         (remprop file 'inputfile))
  2166.      ((setq port ($ofile file))
  2167.         (close port)
  2168.         (remprop file 'outputfile)))
  2169.       (return nil)))
  2170.  
  2171. (df default z
  2172.    (prog (file use)
  2173.       ($reset)
  2174.       (eval-args z)
  2175.       (cond
  2176.      ((not (eq ($parametercount) 2))
  2177.         (!%warn "default: wrong number of arguments" z)
  2178.         (return nil)))
  2179.       (setq file ($parameter 1))
  2180.       (setq use ($parameter 2))
  2181.       (cond
  2182.      ((not (idp file))
  2183.         (!%warn "default: illegal file identifier" file)
  2184.         (return nil))
  2185.      ((not (memq use '(write accept trace)))
  2186.         (!%warn "default: illegal use for a file" use)
  2187.         (return nil))
  2188.      ((and
  2189.          (memq use '(write trace))
  2190.          (not (null file))
  2191.          (not ($ofile file)))
  2192.         (!%warn
  2193.            "default: file has not been opened for output"
  2194.            file)
  2195.         (return nil))
  2196.      ((and
  2197.          (eq use 'accept)
  2198.          (not (null file))
  2199.          (not ($ifile file)))
  2200.         (!%warn
  2201.            "default: file has not been opened for input"
  2202.            file)
  2203.         (return nil))
  2204.      ((eq use 'write) (setq *write-file* file))
  2205.      ((eq use 'accept) (setq *accept-file* file))
  2206.      ((eq use 'trace) (setq *trace-file* file)))
  2207.       (return nil)))
  2208.  
  2209.  
  2210. %%% RHS Functions
  2211.  
  2212. (df accept z
  2213.    (prog (port arg)
  2214.       (cond
  2215.      ((igreaterp (length z) 1)
  2216.         (!%warn "accept: wrong number of arguments" z)
  2217.         (return nil)))
  2218.       (setq port nil)
  2219.       (cond
  2220.      (*accept-file*
  2221.         (setq port ($ifile *accept-file*))
  2222.         (cond
  2223.            ((null port)
  2224.           (!%warn
  2225.              "accept: file has been closed"
  2226.              *accept-file*)
  2227.           (return nil)))) )
  2228.       (cond
  2229.      ((eq (length z) 1)
  2230.         (setq arg ($varbind (car z)))
  2231.         (cond
  2232.            ((not (idp arg))
  2233.           (!%warn "accept: illegal file name" arg)
  2234.           (return nil)))
  2235.         (setq port ($ifile arg))
  2236.         (cond
  2237.            ((null port)
  2238.           (!%warn "accept: file not open for input" arg)
  2239.           (return nil)))) )
  2240.       (cond
  2241.      ((eq (!!tyipeek port) (!!minus 1))
  2242.         ($value 'end-of-file)
  2243.         (return nil)))
  2244.       (flat-value (!!read port))))
  2245.  
  2246. (de flat-value (x)
  2247.    (cond ((atom x) ($value x)) (t (!!mapc (function flat-value) x))))
  2248.  
  2249. (de span-chars (x prt)
  2250.  (prog (ch)
  2251.    (setq ch (!!tyipeek prt))
  2252.    (while (member ch x)
  2253.       (progn (!!readc prt) (setq ch (!!tyipeek prt))))))
  2254.  
  2255. (df acceptline z
  2256.    (prog (c def arg port)
  2257.       (setq port nil)
  2258.       (setq def z)
  2259.       (cond
  2260.      (*accept-file*
  2261.         (setq port ($ifile *accept-file*))
  2262.         (cond
  2263.            ((null port)
  2264.           (!%warn
  2265.              "acceptline: file has been closed"
  2266.              *accept-file*)
  2267.           (return nil)))) )
  2268.       (cond
  2269.      ((pairp def)          %% replaces the awful (greaterp (length def) 0)
  2270.         (setq arg ($varbind (car def)))
  2271.         (cond
  2272.            ((and (idp arg) ($ifile arg))
  2273.           (setq port ($ifile arg))
  2274.           (setq def (cdr def)))) ))
  2275.       (span-chars '(9 41) port)
  2276.       (setq c (tyi port))
  2277.       (cond
  2278.      ((memq (!!tyipeek port) '(-1 10))
  2279.         (!!mapc (function $change) def)
  2280.         (return nil)))
  2281. l:    (flat-value (!!read port))
  2282.       (span-chars '(9 41) port)
  2283.       (cond
  2284.      ((not (memq (!!tyipeek port) '(difference1 10)))
  2285.         (go l:)))) )
  2286.  
  2287. (df substr l
  2288.    (prog (k elm start end)
  2289.       (cond
  2290.      ((not (eq (length l) 3))
  2291.         (!%warn "substr: wrong number of arguments" l)
  2292.         (return nil)))
  2293.       (setq elm (get-ce-var-bind (car l)))
  2294.       (cond
  2295.      ((null elm)
  2296.         (!%warn "first argument to substr must be a ce var" l)
  2297.         (return nil)))
  2298.       (setq start ($varbind (cadr l)))
  2299.       (setq start ($litbind start))
  2300.       (cond
  2301.      ((not (numberp start))
  2302.         (!%warn "second argument to substr must be a number" l)
  2303.         (return nil)))
  2304.       %%   if a variable is bound to INF, the following
  2305.       %%   will get the binding and treat it as INF is
  2306.       %%   always treated.  That may not be good.
  2307.       (setq end ($varbind (caddr l)))
  2308.       (cond ((eq end 'inf) (setq end (length elm))))
  2309.       (setq end ($litbind end))
  2310.       (cond
  2311.      ((not (numberp end))
  2312.         (!%warn "third argument to substr must be a number" l)
  2313.         (return nil)))
  2314.       %%   this loop does not check for the end of elm
  2315.       %%   instead it relies on cdr of nil being nil
  2316.       %%   this may not work in all versions of lisp
  2317.       (setq k 1)
  2318. la    (cond
  2319.      ((igreaterp k end) (return nil))
  2320.      ((not (ilessp k start)) ($value (car elm))))
  2321.       (setq elm (cdr elm))
  2322.       (setq k (iadd1 k))
  2323.       (go la)))
  2324.  
  2325. (df compute z ($value (ari z)))
  2326.  
  2327. % arith is the obsolete form of compute
  2328. (df arith z ($value (ari z)))
  2329.  
  2330. (de ari (x)
  2331.    (cond
  2332.       ((atom x) (!%warn "bad syntax in arithmetic expression " x) 0)
  2333.       ((atom (cdr x)) (ari-unit (car x)))
  2334.       ((eq (cadr x) '+) (plus (ari-unit (car x)) (ari (cddr x))))
  2335.       ((eq (cadr x) '-)
  2336.      (difference (ari-unit (car x)) (ari (cddr x))))
  2337.       ((eq (cadr x) '*) (times (ari-unit (car x)) (ari (cddr x))))
  2338.       ((eq (cadr x) '!/)
  2339.      (quotient (ari-unit (car x)) (ari (cddr x))))
  2340.       ((eq (cadr x) '!!)
  2341.      (mod (fix (ari-unit (car x))) (fix (ari (cddr x)))) )
  2342.       (t (!%warn "bad syntax in arithmetic expression " x) 0)))
  2343.  
  2344. (de ari-unit (a)
  2345.    (prog (r)
  2346.       (cond ((pairp a) (setq r (ari a))) (t (setq r ($varbind a))))
  2347.       (cond
  2348.      ((not (numberp r))
  2349.         (!%warn "bad value in arithmetic expression" a)
  2350.         (return 0))
  2351.      (t (return r)))) )
  2352.  
  2353. (de genatom nil ($value (gensym)))
  2354.  
  2355. (df litval z
  2356.    (prog (r)
  2357.       (cond
  2358.      ((not (eq (length z) 1))
  2359.         (!%warn "litval: wrong number of arguments" z)
  2360.         ($value 0)
  2361.         (return nil))
  2362.      ((numberp (car z)) ($value (car z)) (return nil)))
  2363.       (setq r ($litbind ($varbind (car z))))
  2364.       (cond ((numberp r) ($value r) (return nil)))
  2365.       (!%warn "litval: argument has no literal binding" (car z))
  2366.       ($value 0)))
  2367.  
  2368. (df rjust z
  2369.    (prog (val)
  2370.       (cond
  2371.      ((not (eq (length z) 1))
  2372.         (!%warn "rjust: wrong number of arguments" z)
  2373.         (return nil)))
  2374.       (setq val ($varbind (car z)))
  2375.       (cond
  2376.      ((or (not (numberp val)) (ilessp val 1) (igreaterp val 127))
  2377.         (!%warn "rjust: illegal value for field width" val)
  2378.         (return nil)))
  2379.       ($value "=== R J U S T ===")
  2380.       ($value val)))
  2381.  
  2382. (df crlf z
  2383.    (cond
  2384.       (z (!%warn "crlf: does not take arguments" z))
  2385.       (t ($value "=== C R L F ==="))))
  2386.  
  2387. (df tabto z
  2388.    (prog (val)
  2389.       (cond
  2390.      ((not (eq (length z) 1))
  2391.         (!%warn "tabto: wrong number of arguments" z)
  2392.         (return nil)))
  2393.       (setq val ($varbind (car z)))
  2394.       (cond
  2395.      ((or (not (numberp val)) (ilessp val 1) (igreaterp val 127))
  2396.         (!%warn "tabto: illegal column number" z)
  2397.         (return nil)))
  2398.       ($value "=== T A B T O ===")
  2399.       ($value val)))
  2400.  
  2401. %%% Printing WM
  2402.  
  2403. (df ppwm avlist
  2404.    (prog (next a)
  2405.       (setq *filters* nil)
  2406.       (setq next 1)
  2407. l:    (cond ((atom avlist) (go print)))
  2408.       (setq a (car avlist))
  2409.       (setq avlist (cdr avlist))
  2410.       (cond
  2411.      ((eq a '!^)
  2412.         (setq next (car avlist))
  2413.         (setq avlist (cdr avlist))
  2414.         (setq next ($litbind next))
  2415.         (and (floatp next) (setq next (fix next)))
  2416.         (cond
  2417.            ((or
  2418.            (not (numberp next))
  2419.            (igreaterp next *size-result-array*)
  2420.            (igreaterp 1 next))
  2421.           (!%warn "illegal index after ^" next)
  2422.           (return nil))))
  2423.      ((variablep a)
  2424.         (!%warn "ppwm does not take variables" a)
  2425.         (return nil))
  2426.      (t (setq *filters* (cons next (cons a *filters*)))
  2427.         (setq next (iadd1 next))))
  2428.       (go l:)
  2429. print (mapwm (function ppwm2))
  2430.       (terpri)
  2431.       (return nil)))
  2432.  
  2433. (de ppwm2 (elm-tag)
  2434.    (cond ((filter (car elm-tag)) (terpri) (ppelm (car elm-tag) nil))))
  2435.  
  2436. (de filter (elm)
  2437.    (prog (fl indx val)
  2438.       (setq fl *filters*)
  2439. top   (cond ((atom fl) (return t)))
  2440.       (setq indx (car fl))
  2441.       (setq val (cadr fl))
  2442.       (setq fl (cddr fl))
  2443.       (cond ((ident (nth (isub1 indx) elm) val) (go top)))
  2444.       (return nil)))
  2445.  
  2446. (de ident (x y)
  2447.    (cond
  2448.       ((eq x y) t)
  2449.       ((not (numberp x)) nil)
  2450.       ((not (numberp y)) nil)
  2451.       ((=alg x y) t)
  2452.       (t nil)))
  2453.  
  2454. % the new ppelm is designed especially to handle literalize format
  2455. % however, it will do as well as the old ppelm on other formats
  2456. (de ppelm (elm port)
  2457.    (prog (ppdat sep val att mode lastpos curpos vlist)
  2458.       (!!princ (creation-time elm) port)
  2459.       (!!princ ":  " port)
  2460.       (setq mode 'vector)
  2461.       (setq ppdat (get (car elm) 'ppdat))
  2462.       (and ppdat (setq mode 'a-v))
  2463.       (setq sep "(")
  2464.       (setq lastpos 0)
  2465.       (setq curpos 1) (setq vlist elm)
  2466.       (while (not (atom vlist))
  2467.        (progn
  2468.      (setq val (car vlist))
  2469.      (setq att (assoc curpos ppdat))
  2470.      (cond (att (setq att (cdr att))) (t (setq att curpos)))
  2471.      (and
  2472.         (idp att)
  2473.         (is-vector-attribute att)
  2474.         (setq mode 'vector))
  2475.      (cond
  2476.         ((or (not (null val)) (eq mode 'vector))
  2477.            (!!princ sep port)
  2478.            (ppval val att lastpos port)
  2479.            (setq sep "    ")
  2480.            (setq lastpos curpos)))
  2481.      (setq curpos (iadd1 curpos))
  2482.      (setq vlist (cdr vlist))))
  2483.       (!!princ ")" port)))
  2484.  
  2485. (de ppval (val att lastpos port)
  2486.    (cond
  2487.       ((not (eq att (iadd1 lastpos)))
  2488.      (!!princ '!^ port)
  2489.      (!!princ att port)
  2490.      (!!princ " " port)))
  2491.    (!!princ val port))
  2492.  
  2493. %%% printing production memory
  2494.  
  2495. (df pm z (!!mapc (function pprule) z) (terpri) nil)
  2496.  
  2497. (de pprule (name)
  2498.    (prog (matrix next lab)
  2499.       (cond ((not (idp name)) (return nil)))
  2500.       (setq matrix (get name 'production))
  2501.       (cond ((null matrix) (return nil)))
  2502.       (terpri)
  2503.       (princ "(p ")
  2504.       (princ name)
  2505. top   (cond ((atom matrix) (go fin)))
  2506.       (setq next (car matrix))
  2507.       (setq matrix (cdr matrix))
  2508.       (setq lab nil)
  2509.       (terpri)
  2510.       (cond
  2511.      ((eq next '-)
  2512.         (princ "  - ")
  2513.         (setq next (car matrix))
  2514.         (setq matrix (cdr matrix)))
  2515.      ((eq next '-->) (princ "  "))
  2516.      ((and (eq next '!{) (atom (car matrix)))
  2517.         (princ "   {")
  2518.         (setq lab (car matrix))
  2519.         (setq next (cadr matrix))
  2520.         (setq matrix (cdddr matrix)))
  2521.      ((eq next '!{)
  2522.         (princ "   {")
  2523.         (setq lab (cadr matrix))
  2524.         (setq next (car matrix))
  2525.         (setq matrix (cdddr matrix)))
  2526.      (t (princ "    ")))
  2527.       (ppline next)
  2528.       (cond (lab (princ " ") (princ lab) (princ '!})))
  2529.       (go top)
  2530. fin   (princ ")")))
  2531.  
  2532. (de ppline (line)
  2533.    (prog ()
  2534.       (cond
  2535.      ((atom line) (princ line))
  2536.      (t (princ "(") (setq *ppline* line) (ppline2) (princ ")")))
  2537.       (return nil)))
  2538.  
  2539. (de ppline2 ()
  2540.    (prog (needspace)
  2541.       (setq needspace nil)
  2542. top   (cond ((atom *ppline*) (return nil)))
  2543.       (and needspace (princ " "))
  2544.       (cond ((eq (car *ppline*) '!^) (ppattval)) (t (pponlyval)))
  2545.       (setq needspace t)
  2546.       (go top)))
  2547.  
  2548. (de ppattval ()
  2549.    (prog (att val)
  2550.       (setq att (cadr *ppline*))
  2551.       (setq *ppline* (cddr *ppline*))
  2552.       (setq val (getval))
  2553.       (cond
  2554.      ((greaterp (iplus (posn) (flatc att) (flatc val)) 76)
  2555.         (terpri)
  2556.         (princ "        ")))
  2557.       (princ '!^)
  2558.       (princ att)
  2559.       (!!mapc (function (lambda (z) (princ " ") (princ z))) val)))
  2560.  
  2561. (de pponlyval ()
  2562.    (prog (val needspace)
  2563.       (setq val (getval))
  2564.       (setq needspace nil)
  2565.       (cond
  2566.      ((greaterp (iplus (posn) (flatc val)) 76)
  2567.         (setq needspace nil)
  2568.         (terpri)
  2569.         (princ "        ")))
  2570. top   (cond ((atom val) (return nil)))
  2571.       (and needspace (princ " "))
  2572.       (setq needspace t)
  2573.       (princ (car val))
  2574.       (setq val (cdr val))
  2575.       (go top)))
  2576.  
  2577. (de getval ()
  2578.    (prog (res v1)
  2579.       (setq v1 (car *ppline*))
  2580.       (setq *ppline* (cdr *ppline*))
  2581.       (cond
  2582.      ((memq v1 '(= <> < <= => > <=>))
  2583.         (setq res (cons v1 (getval))))
  2584.      ((eq v1 '!{) (setq res (cons v1 (getupto '!}))))
  2585.      ((eq v1 '<<) (setq res (cons v1 (getupto '>>))))
  2586.      ((eq v1 '!/)
  2587.         (setq res (list v1 (car *ppline*)))
  2588.         (setq *ppline* (cdr *ppline*)))
  2589.      (t (setq res (list v1))))
  2590.       (return res)))
  2591.  
  2592. (de getupto (end)
  2593.    (prog (v)
  2594.       (cond ((atom *ppline*) (return nil)))
  2595.       (setq v (car *ppline*))
  2596.       (setq *ppline* (cdr *ppline*))
  2597.       (cond
  2598.      ((eq v end) (return (list v)))
  2599.      (t (return (cons v (getupto end)))) )))
  2600.  
  2601.  
  2602. %%% backing up
  2603.  
  2604. (de record-index-plus (k)
  2605.    (setq *record-index* (iplus k *record-index*))
  2606.    (cond
  2607.       ((lessp *record-index* 0)
  2608.      (setq *record-index* *max-record-index*))
  2609.       ((greaterp *record-index* *max-record-index*)
  2610.      (setq *record-index* 0))))
  2611.  
  2612. % the following routine initializes the record.  putting nil in the
  2613. % first slot indicates that that the record does not go back further
  2614. % than that.  (when the system backs up, it writes nil over the used
  2615. % records so that it will recognize which records it has used.  thus
  2616. % the system is set up anyway never to back over a nil.)
  2617. (de initialize-record nil
  2618.    (setq *record-index* 0)
  2619.    (setq *recording* nil)
  2620.    (setq *max-record-index* 31)
  2621.    (putv *record-array* 0 nil))
  2622.  
  2623. % *max-record-index* holds the maximum legal index for record-array
  2624. % so it and the following must be changed at the same time
  2625. (de begin-record (p data)
  2626.    (setq *recording* t)
  2627.    (setq *record* (list '=>refract p data)))
  2628.  
  2629. (de end-record nil
  2630.    (cond
  2631.       (*recording*
  2632.      (setq *record*
  2633.         (cons *cycle-count* (cons *p-name* *record*)))
  2634.      (record-index-plus 1)
  2635.      (putv *record-array* *record-index* *record*)
  2636.      (setq *record* nil)
  2637.      (setq *recording* nil))))
  2638.  
  2639. (de record-change (direct time elm)
  2640.    (cond
  2641.       (*recording*
  2642.      (setq *record*
  2643.         (cons direct (cons time (cons elm *record*)))) )))
  2644.  
  2645. % to maintain refraction information, need keep only one piece of information:
  2646. % need to record all unsuccessful attempts to delete things from the conflict
  2647. % set.  unsuccessful deletes are caused by attempting to delete refracted
  2648. % instantiations.  when backing up, have to avoid putting things back into the
  2649. % conflict set if they were not deleted when running forward
  2650. (de record-refract (rule data)
  2651.    (and
  2652.       *recording*
  2653.       (setq *record*
  2654.      (cons '<=refract (cons rule (cons data *record*)))) ))
  2655.  
  2656. (de refracted (rule data)
  2657.    (prog (z)
  2658.       (cond ((null *refracts*) (return nil)))
  2659.       (setq z (cons rule data))
  2660.       (return (member z *refracts*))))
  2661.  
  2662. (de back (k)
  2663.    (prog (r)
  2664. l:    (cond ((lessp k 1) (return nil)))
  2665.       (setq r (getv *record-array* *record-index*))
  2666.       (cond ((null r) (return "nothing more stored")))
  2667.       (putv *record-array* *record-index* nil)
  2668.       (record-index-plus (!!minus 1))
  2669.       (undo-record r)
  2670.       (setq k (isub1 k))
  2671.       (go l:)))
  2672.  
  2673. (de undo-record (r)
  2674.    (prog (save act a b rate)
  2675.       %% *recording* must be off during back up
  2676.       (setq save *recording*)
  2677.       (setq *refracts* nil)
  2678.       (setq *recording* nil)
  2679.       (and *ptrace* (back-print (list 'undo: (car r) (cadr r))))
  2680.       (setq r (cddr r))
  2681. top   (cond ((atom r) (go fin)))
  2682.       (setq act (car r))
  2683.       (setq a (cadr r))
  2684.       (setq b (caddr r))
  2685.       (setq r (cdddr r))
  2686.       (and *wtrace* (back-print (list 'undo: act a)))
  2687.       (cond
  2688.      ((eq act '<=wm) (add-to-wm b a))
  2689.      ((eq act '=>wm) (remove-from-wm b))
  2690.      ((eq act '<=refract)
  2691.         (setq *refracts* (cons (cons a b) *refracts*)))
  2692.      ((and (eq act '=>refract) (still-present b))
  2693.         (setq *refracts* (delete (cons a b) *refracts*))
  2694.         (setq rate (rating-part (get a 'topnode)))
  2695.         (removecs a b)
  2696.         (insertcs a b rate))
  2697.      (t (!%warn "back: cannot undo action" (list act a))))
  2698.       (go top)
  2699. fin   (setq *recording* save)
  2700.       (setq *refracts* nil)
  2701.       (return nil)))
  2702.  
  2703. % still-present makes sure that the user has not deleted something
  2704. % from wm which occurs in the instantiation about to be restored; it
  2705. % makes the check by determining whether each wme still has a time tag.
  2706. (de still-present (data)
  2707.    (prog nil
  2708. l:    (cond
  2709.      ((atom data) (return t))
  2710.      ((creation-time (car data)) (setq data (cdr data)) (go l:))
  2711.      (t (return nil)))) )
  2712.  
  2713. (de back-print (x)
  2714.    (prog (port)
  2715.       (setq port (trace-file))
  2716.       (terpri port)
  2717.       (print x port)))
  2718.  
  2719. %%% Functions to show how close rules are to firing
  2720.  
  2721. (df matches rule-list
  2722.    (!!mapc (function matches2) rule-list)
  2723.    (terpri))
  2724.  
  2725. (de matches2 (p)
  2726.    (cond
  2727.       ((atom p)
  2728.      (terpri)
  2729.      (terpri)
  2730.      (princ p)
  2731.      (matches3 (get p 'backpointers) 2 (ncons 1)))) )
  2732.  
  2733. (de matches3 (nodes ce part)
  2734.    (cond
  2735.       ((not (null nodes))
  2736.      (terpri)
  2737.      (princ " ** matches for ")
  2738.      (princ part)
  2739.      (princ " ** ")
  2740.      (!!mapc (function write-elms) (find-left-mem (car nodes)))
  2741.      (terpri)
  2742.      (princ " ** matches for ")
  2743.      (princ (ncons ce))
  2744.      (princ " ** ")
  2745.      (!!mapc (function write-elms) (find-right-mem (car nodes)))
  2746.      (matches3 (cdr nodes) (iadd1 ce) (cons ce part)))) )
  2747.  
  2748. (de write-elms (wme-or-count)
  2749.    (cond
  2750.       ((pairp wme-or-count)
  2751.      (terpri)
  2752.      (!!mapc (function write-elms2) wme-or-count))))
  2753.  
  2754. (de write-elms2 (x) (princ "  ") (princ (creation-time x)))
  2755.  
  2756. (de find-left-mem (node)
  2757.    (cond
  2758.       ((eq (car node) '&and) (memory-part (caddr node)))
  2759.       (t (car (caddr node)))) )
  2760.  
  2761. (de find-right-mem (node) (memory-part (cadddr node)))
  2762.  
  2763. %%% Check the RHSs of productions
  2764.  
  2765. (de check-rhs (rhs) (!!mapc (function check-action) rhs))
  2766.  
  2767. (de check-action (x)
  2768.    (prog (a)
  2769.       (cond ((atom x) (!%warn "atomic action" x) (return nil)))
  2770.       (setq a (setq *action-type* (car x)))
  2771.       (cond
  2772.      ((eq a 'bind) (check-bind x))
  2773.      ((eq a 'cbind) (check-cbind x))
  2774.      ((eq a 'make) (check-make x))
  2775.      ((eq a 'modify) (check-modify x))
  2776.      ((eq a 'remove) (check-remove x))
  2777.      ((eq a 'write) (check-write x))
  2778.      ((eq a 'call) (check-call x))
  2779.      ((eq a 'halt) (check-halt x))
  2780.      ((eq a 'openfile) (check-openfile x))
  2781.      ((eq a 'closefile) (check-closefile x))
  2782.      ((eq a 'default) (check-default x))
  2783.      ((eq a 'build) (check-build x))
  2784.      (t (!%warn "undefined rhs action" a)))) )
  2785.  
  2786. (de check-build (z)
  2787.    (and (null (cdr z)) (!%warn "needs arguments" z))
  2788.    (check-build-collect (cdr z)))
  2789.  
  2790. (de check-build-collect (args)
  2791.    (prog (r)
  2792. top   (cond ((null args) (return nil)))
  2793.       (setq r (car args))
  2794.       (setq args (cdr args))
  2795.       (cond
  2796.      ((pairp r) (check-build-collect r))
  2797.      ((eq r '!!)
  2798.         (and (null args) (!%warn "nothing to evaluate" r))
  2799.         (check-rhs-value (car args))
  2800.         (setq args (cdr args))))
  2801.       (go top)))
  2802.  
  2803. (de check-remove (z)
  2804.    (and (null (cdr z)) (!%warn "needs arguments" z))
  2805.    (!!mapc (function check-rhs-ce-var) (cdr z)))
  2806.  
  2807. (de check-make (z)
  2808.    (and (null (cdr z)) (!%warn "needs arguments" z))
  2809.    (check-change& (cdr z)))
  2810.  
  2811. (de check-openfile (z)
  2812.    (and (null (cdr z)) (!%warn "needs arguments" z))
  2813.    (check-change& (cdr z)))
  2814.  
  2815. (de check-closefile (z)
  2816.    (and (null (cdr z)) (!%warn "needs arguments" z))
  2817.    (check-change& (cdr z)))
  2818.  
  2819. (de check-default (z)
  2820.    (and (null (cdr z)) (!%warn "needs arguments" z))
  2821.    (check-change& (cdr z)))
  2822.  
  2823. (de check-modify (z)
  2824.    (and (null (cdr z)) (!%warn "needs arguments" z))
  2825.    (check-rhs-ce-var (cadr z))
  2826.    (and (null (cddr z)) (!%warn "no changes to make" z))
  2827.    (check-change& (cddr z)))
  2828.  
  2829. (de check-write (z)
  2830.    (and (null (cdr z)) (!%warn "needs arguments" z))
  2831.    (check-change& (cdr z)))
  2832.  
  2833. (de check-call (z)
  2834.    (prog (f)
  2835.       (and (null (cdr z)) (!%warn "needs arguments" z))
  2836.       (setq f (cadr z))
  2837.       (and
  2838.      (variablep f)
  2839.      (!%warn "function name must be a constant" z))
  2840.       (or
  2841.      (idp f)
  2842.      (!%warn "function name must be a symbolic atom" f))
  2843.       (or
  2844.      (externalp f)
  2845.      (!%warn "function name not declared external" f))
  2846.       (check-change& (cddr z))))
  2847.  
  2848. (de check-halt (z)
  2849.    (or (null (cdr z)) (!%warn "does not take arguments" z)))
  2850.  
  2851. (de check-cbind (z)
  2852.    (prog (v)
  2853.       (or (eq (length z) 2) (!%warn "takes only one argument" z))
  2854.       (setq v (cadr z))
  2855.       (or (variablep v) (!%warn "takes variable as argument" z))
  2856.       (note-ce-variable v)))
  2857.  
  2858. (de check-bind (z)
  2859.    (prog (v)
  2860.       (or (igreaterp (length z) 1) (!%warn "needs arguments" z))
  2861.       (setq v (cadr z))
  2862.       (or (variablep v) (!%warn "takes variable as argument" z))
  2863.       (note-variable v)
  2864.       (check-change& (cddr z))))
  2865.  
  2866. (de check-change& (z)
  2867.    (prog (r tab-flag)
  2868.       (setq tab-flag nil)
  2869. la    (cond ((atom z) (return nil)))
  2870.       (setq r (car z))
  2871.       (setq z (cdr z))
  2872.       (cond
  2873.      ((eq r '!^)
  2874.         (and
  2875.            tab-flag
  2876.            (!%warn "no value before this tab" (car z)))
  2877.         (setq tab-flag t)
  2878.         (check-tab-index (car z))
  2879.         (setq z (cdr z)))
  2880.      ((eq r '!/) (setq tab-flag nil) (setq z (cdr z)))
  2881.      (t (setq tab-flag nil) (check-rhs-value r)))
  2882.       (go la)))
  2883.  
  2884. (de check-rhs-ce-var (v)
  2885.    (cond
  2886.       ((and (not (numberp v)) (not (ce-bound? v)))
  2887.      (!%warn "unbound element variable" v))
  2888.       ((and (numberp v) (or (lessp v 1) (greaterp v *ce-count*)))
  2889.      (!%warn "numeric element designator out of bounds" v))))
  2890.  
  2891. (de check-rhs-value (x)
  2892.    (cond ((pairp x) (check-rhs-function x)) (t (check-rhs-atomic x))))
  2893.  
  2894. (de check-rhs-atomic (x)
  2895.    (and
  2896.       (variablep x)
  2897.       (not (bound? x))
  2898.       (!%warn "unbound variable" x)))
  2899.  
  2900. (de check-rhs-function (x)
  2901.    (prog (a)
  2902.       (setq a (car x))
  2903.       (cond
  2904.      ((eq a 'compute) (check-compute x))
  2905.      ((eq a 'arith) (check-compute x))
  2906.      ((eq a 'substr) (check-substr x))
  2907.      ((eq a 'accept) (check-accept x))
  2908.      ((eq a 'acceptline) (check-acceptline x))
  2909.      ((eq a 'crlf) (check-crlf x))
  2910.      ((eq a 'genatom) (check-genatom x))
  2911.      ((eq a 'litval) (check-litval x))
  2912.      ((eq a 'tabto) (check-tabto x))
  2913.      ((eq a 'rjust) (check-rjust x))
  2914.      ((not (externalp a))
  2915.         (!%warn "rhs function not declared external" a)))) )
  2916.  
  2917. (de check-litval (x)
  2918.    (or (eq (length x) 2) (!%warn "wrong number of arguments" x))
  2919.    (check-rhs-atomic (cadr x)))
  2920.  
  2921. (de check-accept (x)
  2922.    (cond
  2923.       ((eq (length x) 1) nil)
  2924.       ((eq (length x) 2) (check-rhs-atomic (cadr x)))
  2925.       (t (!%warn "too many arguments" x))))
  2926.  
  2927. (de check-acceptline (x)
  2928.    (!!mapc (function check-rhs-atomic) (cdr x)))
  2929.  
  2930. (de check-crlf (x) (check-0-args x))
  2931.  
  2932. (de check-genatom (x) (check-0-args x))
  2933.  
  2934. (de check-tabto (x)
  2935.    (or (eq (length x) 2) (!%warn "wrong number of arguments" x))
  2936.    (check-print-control (cadr x)))
  2937.  
  2938. (de check-rjust (x)
  2939.    (or (eq (length x) 2) (!%warn "wrong number of arguments" x))
  2940.    (check-print-control (cadr x)))
  2941.  
  2942. (de check-0-args (x)
  2943.    (or (eq (length x) 1) (!%warn "should not have arguments" x)))
  2944.  
  2945. (de check-substr (x)
  2946.    (or (eq (length x) 4) (!%warn "wrong number of arguments" x))
  2947.    (check-rhs-ce-var (cadr x))
  2948.    (check-substr-index (caddr x))
  2949.    (check-last-substr-index (cadddr x)))
  2950.  
  2951. (de check-compute (x) (check-arithmetic (cdr x)))
  2952.  
  2953. (de check-arithmetic (l)
  2954.    (cond
  2955.       ((atom l) (!%warn "syntax error in arithmetic expression" l))
  2956.       ((atom (cdr l)) (check-term (car l)))
  2957.       ((not (memq (cadr l) '(+ - * !/)))
  2958.      (!%warn "unknown operator" l))
  2959.       (t (check-term (car l)) (check-arithmetic (cddr l)))) )
  2960.  
  2961. (de check-term (x)
  2962.    (cond ((pairp x) (check-arithmetic x)) (t (check-rhs-atomic x))))
  2963.  
  2964. (de check-last-substr-index (x)
  2965.    (or (eq x 'inf) (check-substr-index x)))
  2966.  
  2967. (de check-substr-index (x)
  2968.    (prog (v)
  2969.       (cond ((bound? x) (return x)))
  2970.       (setq v ($litbind x))
  2971.       (cond
  2972.      ((not (numberp v))
  2973.         (!%warn "unbound symbol used as index in substr" x))
  2974.      ((or (lessp v 1) (greaterp v 127))
  2975.         (!%warn "index out of bounds in tab" x)))) )
  2976.  
  2977. (de check-print-control (x)
  2978.    (prog ()
  2979.       (cond ((bound? x) (return x)))
  2980.       (cond
  2981.      ((or (not (numberp x)) (lessp x 1) (greaterp x 127))
  2982.         (!%warn "illegal value for printer control" x)))) )
  2983.  
  2984. (de check-tab-index (x)
  2985.    (prog (v)
  2986.       (cond ((bound? x) (return x)))
  2987.       (setq v ($litbind x))
  2988.       (cond
  2989.      ((not (numberp v))
  2990.         (!%warn "unbound symbol occurs after ^" x))
  2991.      ((or (lessp v 1) (greaterp v 127))
  2992.         (!%warn "index out of bounds after ^" x)))) )
  2993.  
  2994. (de note-variable (var)
  2995.    (setq *rhs-bound-vars* (cons var *rhs-bound-vars*)))
  2996.  
  2997. (de bound? (var) (or (memq var *rhs-bound-vars*) (var-dope var)))
  2998.  
  2999. (de note-ce-variable (ce-var)
  3000.    (setq *rhs-bound-ce-vars* (cons ce-var *rhs-bound-ce-vars*)))
  3001.  
  3002. (de ce-bound? (ce-var)
  3003.    (or (memq ce-var *rhs-bound-ce-vars*) (ce-var-dope ce-var)))
  3004.  
  3005. %%% Top level routines
  3006.  
  3007. (de process-changes (adds dels)
  3008.    (prog (x)
  3009. process-deletes
  3010.       (cond ((atom dels) (go process-adds)))
  3011.       (setq x (car dels))
  3012.       (setq dels (cdr dels))
  3013.       (remove-from-wm x)
  3014.       (go process-deletes)
  3015. process-adds
  3016.       (cond ((atom adds) (return nil)))
  3017.       (setq x (car adds))
  3018.       (setq adds (cdr adds))
  3019.       (add-to-wm x nil)
  3020.       (go process-adds)))
  3021.  
  3022. (de main nil
  3023.    (prog (instance r)
  3024.       (setq *halt-flag* nil)
  3025.       (setq *break-flag* nil)
  3026.       (setq instance nil)
  3027. dil   (setq *phase* 'conflict-resolution)
  3028.       (cond
  3029.      (*halt-flag* (setq r "end -- explicit halt") (go finis))
  3030.      ((izerop *remaining-cycles*)
  3031.         (setq r '***break***)
  3032.         (setq *break-flag* t)
  3033.         (go finis))
  3034.      (*break-flag* (setq r '***break***) (go finis)))
  3035.       (setq *remaining-cycles* (isub1 *remaining-cycles*))
  3036.       (setq instance (conflict-resolution))
  3037.       (cond
  3038.      ((not instance)
  3039.         (setq r "end -- no production true")
  3040.         (go finis)))
  3041.       (setq *phase* (car instance))
  3042.       (accum-stats)
  3043.       (eval-rhs (car instance) (cdr instance))
  3044.       (check-limits)
  3045.       (and (broken (car instance)) (setq *break-flag* t))
  3046.       (go dil)
  3047. finis (setq *p-name* nil)
  3048.       (return r)))
  3049.  
  3050. (de do-continue (wmi)
  3051.    (cond
  3052.       (*critical*
  3053.      (terpri)
  3054.      (princ "warning: network may be inconsistent")))
  3055.    (process-changes wmi nil)
  3056.    (print-times (main)))
  3057.  
  3058. (de accum-stats nil
  3059.    (setq *cycle-count* (iadd1 *cycle-count*))
  3060.    (setq *total-token* (iplus *total-token* *current-token*))
  3061.    (cond
  3062.       ((igreaterp *current-token* *max-token*)
  3063.      (setq *max-token* *current-token*)))
  3064.    (setq *total-wm* (iplus *total-wm* *current-wm*))
  3065.    (cond
  3066.       ((greaterp *current-wm* *max-wm*)
  3067.      (setq *max-wm* *current-wm*))))
  3068.  
  3069. (de print-times (mess)
  3070.    (prog (cc ac)
  3071.       (cond (*break-flag* (terpri) (return mess)))
  3072.       (setq cc (plus (float *cycle-count*) 10.0e-20))
  3073.       (setq ac (plus (float *action-count*) 1.0e-20))
  3074.       (terpri)
  3075.       (princ mess)
  3076.       (pm-size)
  3077.       (printlinec
  3078.      (list
  3079.         *cycle-count*
  3080.         'firings
  3081.         (list *action-count* 'rhs 'actions)))
  3082.       (terpri)
  3083.       (printlinec
  3084.      (list
  3085.         (round (quotient (float *total-wm*) cc))
  3086.         'mean
  3087.         'working
  3088.         'memory
  3089.         'size
  3090.         (list *max-wm* 'maximum)))
  3091.       (terpri)
  3092.       (printlinec
  3093.      (list
  3094.         (round (quotient (float *total-cs*) cc))
  3095.         'mean
  3096.         'conflict
  3097.         'set
  3098.         'size
  3099.         (list *max-cs* 'maximum)))
  3100.       (terpri)
  3101.       (printlinec
  3102.      (list
  3103.         (round (quotient (float *total-token*) cc))
  3104.         'mean
  3105.         'token
  3106.         'memory
  3107.         'size
  3108.         (list *max-token* 'maximum)))
  3109.       (terpri)))
  3110.  
  3111. (de pm-size nil
  3112.    (terpri)
  3113.    (printlinec
  3114.       (list
  3115.      *pcount*
  3116.      'productions
  3117.      (list *real-cnt* '!/ *virtual-cnt* 'nodes)))
  3118.    (terpri))
  3119.  
  3120. (de check-limits nil
  3121.    (cond
  3122.       ((igreaterp (length *conflict-set*) *limit-cs*)
  3123.      (terpri)
  3124.      (terpri)
  3125.      (printlinec
  3126.         (list
  3127.            "conflict set size exceeded the limit of"
  3128.            *limit-cs*
  3129.            "after"
  3130.            *p-name*))
  3131.      (setq *halt-flag* t)))
  3132.    (cond
  3133.       ((igreaterp *current-token* *limit-token*)
  3134.      (terpri)
  3135.      (terpri)
  3136.      (printlinec
  3137.         (list
  3138.            "token memory size exceeded the limit of"
  3139.            *limit-token*
  3140.            "after"
  3141.            *p-name*))
  3142.      (setq *halt-flag* t))))
  3143.  
  3144. (de top-level-remove (z)
  3145.    (cond
  3146.       ((equal z '(*)) (process-changes nil (get-wm nil)))
  3147.       (t (process-changes nil (get-wm z)))) )
  3148.  
  3149. (df excise z (!!mapc (function excise-p) z))
  3150.  
  3151. (df run z
  3152.    (cond
  3153.       ((atom z) (setq *remaining-cycles* 1000000) (do-continue nil))
  3154.       ((and (atom (cdr z)) (numberp (car z)) (greaterp (car z) 0))
  3155.      (setq *remaining-cycles* (car z))
  3156.      (do-continue nil))
  3157.       (t 'what?)))
  3158.  
  3159. (df strategy z
  3160.    (cond
  3161.       ((atom z) *strategy*)
  3162.       ((equal z '(lex)) (setq *strategy* 'lex))
  3163.       ((equal z '(mea)) (setq *strategy* 'mea))
  3164.       (t 'what?)))
  3165.  
  3166. (df cs z (cond ((atom z) (conflict-set)) (t 'what?)))
  3167.  
  3168. (df watch z
  3169.    (cond
  3170.       ((equal z '(0)) (setq *wtrace* nil) (setq *ptrace* nil) 0)
  3171.       ((equal z '(1)) (setq *wtrace* nil) (setq *ptrace* t) 1)
  3172.       ((equal z '(2)) (setq *wtrace* t) (setq *ptrace* t) 2)
  3173.       ((equal z '(3))
  3174.      (setq *wtrace* t)
  3175.      (setq *ptrace* t)
  3176.      '(2 -- conflict set trace not supported))
  3177.       ((and (atom z) (null *ptrace*)) 0)
  3178.       ((and (atom z) (null *wtrace*)) 1)
  3179.       ((atom z) 2)
  3180.       (t 'what?)))
  3181.  
  3182. (df external z (catch !!error!! (external2 z)))
  3183.  
  3184. (de external2 (z) (!!mapc (function external3) z))
  3185.  
  3186. (de external3 (x)
  3187.    (cond
  3188.       ((idp x) (putprop x t 'external-routine))
  3189.       (t (!%error "not a legal function name" x))))
  3190.  
  3191. (de externalp (x)
  3192.    (cond
  3193.       ((idp x) (get x 'external-routine))
  3194.       (t (!%warn "not a legal function name" x) nil)))
  3195.  
  3196. (df pbreak z
  3197.    (cond
  3198.       ((atom z) (terpri) *brkpts*)
  3199.       (t (!!mapc (function pbreak2) z) nil)))
  3200.  
  3201. (de pbreak2 (rule)
  3202.    (cond
  3203.       ((not (idp rule)) (!%warn "illegal name" rule))
  3204.       ((not (get rule 'topnode)) (!%warn "not a production" rule))
  3205.       ((memq rule *brkpts*) (setq *brkpts* (rematm rule *brkpts*)))
  3206.       (t (setq *brkpts* (cons rule *brkpts*)))) )
  3207.  
  3208. (de rematm (atm list)
  3209.    (cond
  3210.       ((atom list) list)
  3211.       ((eq atm (car list)) (rematm atm (cdr list)))
  3212.       (t (cons (car list) (rematm atm (cdr list)))) ))
  3213.  
  3214. (de broken (rule) (memq rule *brkpts*))
  3215.  
  3216. (i-g-v)
  3217.  
  3218. (setsyntax '!{ 'read!-macro nil)
  3219. (setsyntax "{}" 'letter t)
  3220. (setsyntax "{}" 'break-character nil)
  3221. (car!-nil!-legal t)
  3222.  
  3223.  
  3224. fin
  3225.  
  3226.